Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 095 / rbbssrc2.arc / RBBSSUB2.BAS < prev

Wrap

BASIC Source File | 1987-03-15 | 145.4 KB | 3,767 lines

' $linesize:132 ' $title: 'RBBSSUB2.BAS CPC15-1A, Copyright 1986 & 87 by D. Thomas Mack' ' Copyright 1987 by D. Thomas Mack, all rights reserved. ' Name ...............: RBBSSUB2.BAS ' Written by .........: D. Thomas Mack ' First Released .....: June 29, 1986 ' Subsequent Releases.: September 28, 1986, March 15, 1987 ' Copyright ..........: 1986, 1987 ' Purpose.............: The Remote Bulletin Board System for the IBM PC, ' RBBS-PC.BAS utilizes a lot of common subroutines. ' Those that do not reqpure error trapping are ' incorporated within RBBSSUB2.BAS as separately call- ' able subroutines in order to free up as much code as ' possible within the 64K code segment used by ' RBBS-PC.BAS. ' Parameters..........: Most parameters are passed via a COMMON statement. ' ' Subroutine Line Function of Subroutine ' Name Number ' ALLCAPS 58060 Convert a string to all upper case characters ' ALLCAPSD 58065 Convert a dimensioned string to all upper case characters ' AMORPM 41500 Calculate the current time as AM or PM ' BADCHAR 455 Check user name for invalid characters ' BADFILE 20741 Check for system crash attempt with bad device name ' BADNAME 20235 Check for system crash attempt with bad file name ' BRKFNAME 20282 Break a file name into it's component parts ' BUFFILE 58400 Write a file to the user quickly ' BUFSTRNG 58300 Write a string with imbedded CR/LF to the user quickly ' CALLOPT 58090 Set prompts based on the user's security ' CARRIER 42000 Test for Carrier present ' CHECKTIM 58070 Test to insure that users don't exceed their time ' CHKNARY 58180 Check for the occurance of a string in an array ' CHKNEWBUL 58110 Check for new bulletins based on their file creation date ' COMMINFO 44000+ Get users baud rate and parity in a string format ' COMPDATE 59200+ Produces a computational data from YY, MM, DD ' CONVDIRS 58950 Checks for U & A (shorthand) and converts appropriately ' COPYWRIT 97 Display RBBS-PC's copyright notice ' CTNEWFILES 58150 Check for number of files uploaded after a specific date ' CTLINES 58160 Find the number of entries in the upload management sys. ' DEFALTU 9600 Write out the user's defaults ' DELAYIT 50500 Wait number of seconds specified before returning ' DISPLAYTR 41010+ Compute and display time remaining ' DISUPDIR 58170 Display the upload directory of the upload mng. sys. ' DOOREXIT 10987 Set up a .BAT file to exit RBBS-PC and go to a "door" ' DOSEXIT 10934 Set up a .BAT file to exit to DOS (second level) ' FILELOCK 21995 Allow files to be shared among multiple RBBS-PC's ' FINDFUNC 58040 Find the function key, if any, that was depressed ' FINDLAST 58600 Finds last occurence of a string in a string ' FINDTIME 58050 Calculate the number of seconds since midnight ' FMS 58200 Search the upload management system for entries ' GETCOMND 97+ Get RBBS-PC's node id from command line ' GETDIRS 58900 Prompts for directories for file list/new/search cmds ' GETIME 9140 Calculates callers elapsed time (hours, minutes, seconds) ' GETYMD 59200 Pulls YY, MM, or DD from a 2 byte stored date ' GRAPHIC 43031 Determines whether graphic version of file exists ' HASHRBBS 58080 "Hash" to a user's record in the USERS file ' HELP 1330 Processes help command ' INSCOMMA 58130 Format commands in the command prompt ' INITFMS 58160+ Initialize the managment upload system ' KILLMSG 3955 Delete old or unnecessary messages ' LINE25 949 Build and/or update line 25 of RBBS-PC's local screen ' LOADNEW 58140 Find the latest uploads ' LOGERROR 13660 Log error message to CALLERS file ' MLINIT 50 Handle MultiLink initialization/de-initialization ' MODEMPUT 52070 Write a modem command string to the modem ' MUSIC 59100 Play musical themes for different RBBS functions ' OPENMSG 30500 Open the messages file as file number 1 ' PROTOCOL 62600 Determine if external protocols are available ' PRTCRLF 1478 Write "snoop" lines that may have imbedded CR/LF's ' QTPUT 1477 Fast, but limited, "TPUT" equivalent ' RBBSEXIT 10992 Common RBBS-PC exit to transfer control to other programs ' READPROF 44000 Read user's profile on return from a "door" ' RECOVMSG 10410 Recover a deleted message ' REMOVE 58210 Remove characters from within strings ' ROTORSDIR 58700 Searches for a file using list of subdirs ' SAVEPROF 43070 Save the user's provile when exiting to "doors" or DOS ' SETBAUD 1654 Set baud rate in the 8250 chip of the RS232 interface ' SETCRLF 1496 Set up the necessary carriage return/line feed string ' SETOPTS 58100 Set correct prompt line for each subsystem ' SKIPLINE 1485 Write a # of blank lines to the communications port ' SRCHCMND 1240 Searches list of commands in RBBS for a request ' SRTSTRNG 58120 Sort characters in a string ' SYSMENU 112 Displays sysop menu/status ' TIMEREMAIN 41010 Compute time remaining in minutes ' TRANSFER 62620 RBBS-PC support for external protocols for file transfer ' TWOBYTEDATE 59200 Reduces a data to 2 byte string for space compression ' UNTILRIGHT 12880 Ask a question until user say answers is right ' UPDATEU 10600 Updates the user record on loging off/exiting RBBS-PC ' UPDTUPLOAD 20705 Updates upload directory file ' VIEWARC 64600 Display .ARC file contents to user ' WILDCARD 20285 Determines whether string matches a pattern ' WIPELINE 58800 Wipes away a line so next prints in its place ' WORDINFILE 10976 Find a whole word within a file/menu ' ' $INCLUDE: 'RBBS-VAR.BAS' ' ' $SUBTITLE: 'MLINIT - MultiLink initialization/deinitialization' ' $PAGE ' ' SUBROUTINE NAME -- MLINIT ' ' INPUT PARAMETERS -- MLPARM = 1 INITIALIZE AT STARTUP OR RE- ' CYLCE TIME ' MLPARM = 2 DE-INITIALIZE ON EXITING TO ' A DOOR OR DOS REMOTELY ' MLPARM = 3 DE-QUEUE COMMUNICATIONS PORTS ' MLPARM = 4 CHECK FOR MULTILINK PRESENT ' DOORS.TERMINAL.TYPE ' BAUD.TEST ' COM.PORT$ ' COMPUTER.TYPE ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO TEST FOR THE PRESENCE OF MULTI-LINK AND SET ' MULTI LINK OPTIONS TO BE COMPATIBLE WITH RBBS-PC ' SUB MLINIT (MLPARM) STATIC DEF SEG = 0 IF COMPUTER.TYPE = 1 _ GOTO 10 IF NOT MLCOM THEN _ IF NETWORK.TYPE <> 1 THEN _ GOTO 10 MULTI.LINK.PRESENT = PEEK(&H1FE) + 256*PEEK(&H1FF) IF MULTI.LINK.PRESENT = 0 THEN _ GOTO 10 ON MLPARM GOSUB 30,20,60,10 10 DEF SEG EXIT SUB 20 IF DOORS.TERMINAL.TYPE < 1 THEN _ RETURN DEF SEG = MULTI.LINK.PRESENT GOSUB 60 ' ' ***************************************************************************** ' * MLUTIL BAUD n (where n = BAUD.TEST) * ' ***************************************************************************** ' AX = &H600 BX = BAUD.TEST ' Tell ML the baud rate GOSUB 80 ' ' ***************************************************************************** ' * MLUTIL TERM n (where n = DOORS.TERMINAL.TYPE) * ' ***************************************************************************** ' AX = &H700 + DOORS.TERMINAL.TYPE GOSUB 80 ' Tell ML the terminal type ' ' ***************************************************************************** ' * MLINK /port * ' ***************************************************************************** ' ' ' Tell ML the communications port POKE (&H64+PEEK(&H58)+256*PEEK(&H59)+&HC),ASC(RIGHT$(COM.PORT$,1))-48 ' ' ***************************************************************************** ' * MLUTIL SCMON * ' ***************************************************************************** ' AX = &HB01 BX = 0 ' Tell ML to start monitoring the carrier GOSUB 80 RETURN ' ' ***************************************************************************** ' * MLUTIL CCMON * ' ***************************************************************************** ' 30 AX = &HB00 ' Turn off ML's carrier monitoring. BX = 0 GOSUB 80 ' ' ***************************************************************************** ' * MLUTIL TERM 1 * ' ***************************************************************************** ' AX = &H701 ' Change terminal type to ML type 1. BX = 0 GOSUB 80 ' ' ***************************************************************************** ' * MLINK /port (where port = 9 if ML 3.03 or earlier * ' * port = 0 if ML 4.00 or greater * ' ***************************************************************************** ' DEF SEG = MULTI.LINK.PRESENT MULTI.LINK.COM.PORT = (&H64 + PEEK(&H58) + 256*PEEK(&H59) + &HC) MULTI.LINK.VERSION = PEEK(&H1) + 256*PEEK(&H2) IF PEEK(MULTI.LINK.COM.PORT) = &H1 OR &H2 THEN _ IF MULTI.LINK.VERSION > 5000 THEN _ POKE (MULTI.LINK.COM.PORT),&H0 _ ELSE POKE (MULTI.LINK.COM.PORT),&H9 ' ' ***************************************************************************** ' * MLUTIL ENQ * ' ***************************************************************************** ' AX = &H1 ' Tell ML to conditional enque on the comm. port GOSUB 70 ' ' ***************************************************************************** ' * MLUTIL BAUD 19200 * ' ***************************************************************************** ' AX = &H600 ' Tell ML to reset the buad rate (19200 BAUD) BX = 19200 GOSUB 80 RETURN ' ' ***************************************************************************** ' * MLUTIL DEQ * ' ***************************************************************************** ' 60 AX = &H100 ' Tell ML to unconditionally deque the comm. port 70 BX = -4 IF COM.PORT$ = "COM2" THEN _ BX = -3 ' ' ***************************************************************************** ' * MULTI-LINK PROGRAMMING SUPPORT INTERFACE * ' ***************************************************************************** ' 80 CALL RBBSML(AX,BX) RETURN END SUB ' $SUBTITLE: 'COPYWRIT - subroutine to display RBBS-PC copyright' ' $PAGE ' ' SUBROUTINE NAME -- COPYWRIT ' ' INPUT PARAMETERS -- NONE ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO DISPLAY RBBS-PC'S COPYRIGHT NOTICE ON THE LOCAL ' SYSOP'S SCREEN ' SUB COPYWRIT STATIC 97 WIDTH 80 CLS KEY OFF LOCATE ,,0 PRINT TAB(60)"tm" PRINT TAB(16) STRING$(15,205)" U S E R W A R E " STRING$(15,205) PRINT PRINT TAB(17)"Capital PC User Group User-Supported Software" PRINT PRINT TAB(5) CHR$(214) STRING$(66,196) CHR$(183) FOR I = 1 TO 12 READ A$ PRINT TAB(5) CHR$(186);A$; SPACE$(66 - LEN(A$)); CHR$(186) NEXT PRINT TAB(5) CHR$(211) STRING$(66,196) CHR$(189) PRINT TAB(21)"Copyright (c) 1983-87 Tom Mack, 10210 Oxfordshire Road, Great Falls, VA" DATA " If you are using RBBS-PC CPC15.1 and find it valuable, I" DATA " suggest you consider a contribution to" DATA "" DATA " Capital PC Software Exchange" DATA " Post Office Box 6128" DATA " Silver Spring, Maryland 20906" DATA "" DATA " You are free to copy and share RBBS-PC CPC15.1 with" DATA " others on these three conditions:" DATA " 1. This program is not distributed in modified form." DATA " 2. No fee or consideration is charged for RBBS-PC, itself." DATA " 3. This notice is not bypassed or removed." CALL DELAYIT (8) END SUB ' $SUBTITLE: 'GETCOMND - subroutine to get command from command line' ' $PAGE ' ' SUBROUTINE NAME -- GETCOMND ' ' INPUT PARAMETERS -- PARAMETER MEANING ' COMMAND LINE COMMAND LINE USED TO INVOKE ' RBBS-PC IN THE FORM: ' ' RBBS-PC.EXE x filename ' ' WHERE: ' ' x IS THE NODE ID IN THE RANGE ' 1-9,0,A-Z AND filename IS THE ' FULLY QUALIFIED FILE NAME TO ' USE AS THE ".DEF" FILE. THIS ' SECOND PARAMETER IS OPTIONAL. ' CONFIG.FILENAME$ NAME OF RBBS-PC ".DEF" FILE TO ' USE AS A MODEL WHEN CREATING THE ' .DEF FILE NAME TO BE USED BY THIS ' COPY OF RBBS-PC. ' ' OUTPUT PARAMETERS -- CONFIG.FILENAME$ NAME OF RBBS-PC ".DEF" FILE FOR ' THIS COPY OF RBBS-PC TO USE ' NODE.RECORD.INDEX RECORD NUMBER WITHIN THE ' MESSAGES FILE FOR THIS "NODE" ' (RANGE IS 2 TO 36) ' ' SUBROUTINE PURPOSE -- TO GET NODE ID FROM COMMAND LINE ' SUB GETCOMND (PASSED.DEBUG) STATIC STATIC DEBUG ' ' ***************************************************************************** ' * GET NODE ID FROM COMMAND LINE * ' ***************************************************************************** ' PM$ = COMMAND$ CALL ALLCAPS(PM$) 98 A = INSTR(PM$,"DEBUG") IF A>0 THEN _ DEBUG = -1 : _ PM$ = LEFT$(PM$,A-1) + RIGHT$(PM$,LEN(PM$)-A-4) PASSED.DEBUG = DEBUG IF LEN(PM$) = 0 THEN _ PM$ = "-" NODE.RECORD.INDEX = INSTR("-1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ",LEFT$(PM$,1)) IF NODE.RECORD.INDEX < 2 THEN _ NODE.RECORD.INDEX = 2 NODE.ID$ = STR$(NODE.RECORD.INDEX-1) IF LEN(PM$) > 2 AND MID$(PM$,2,1) = " " THEN _ CONFIG.FILENAME$ = MID$(PM$,3)_ ELSE MID$(CONFIG.FILENAME$,5,1) = PM$ END SUB ' ' $SUBTITLE: 'SYSMENU - subroutine to display RBBS-PC SYSOP menu' ' $PAGE ' ' SUBROUTINE NAME -- SYSMENU ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DELAY! TIME IN SECONDS AFTER MIDNIGHT TO WAIT ' BEFORE DISPLAYING ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO DISPLAY RBBS-PC's SYSOP MENU ON THE LOCAL SCREEN ' SUB SYSMENU STATIC DELAY! = 0 112 LOCAL.USER = TRUE SNOOP = TRUE PAGE.LENGTH.HOLD = PAGE.LENGTH PAGE.LENGTH = 0 SUBROUTINE.PARAMETER = 1 WHILE SUBROUTINE.PARAMETER = 1 CALL CHECKTIM (DELAY!) WEND CLS BYPASS.TIME.CHECK = TRUE SECONDS.PER.SESSION! = 4 CALL BUFFILE ("MENU0") BYPASS.TIME.CHECK = FALSE LOCAL.USER = FALSE PAGE.LENGTH = PAGE.LENGTH.HOLD IF NOT OK THEN _ PRINT "MENU0 not on default drive" LOCATE 2,18 PRINT LEFT$(VERSION.ID$,8); LOCATE 2,58 X$ = DATE$ PRINT LEFT$(X$,6)+RIGHT$(X$,2); LOCATE 2,72 PRINT LEFT$(TIME$,5); IF DEBUG THEN _ LOCATE 16,1 : _ PRINT "DEBUG Active"; LOCATE 18,23 PRINT NODE.ID$; LOCATE 18,74 PRINT MID$(STR$(FRE("A")),2) IF COLOR.SUPPORT THEN _ LOCATE 20,23 : _ PRINT "YES"; IF RESTRICT.BAUD THEN _ LOCATE 20,51 : _ PRINT "NO "; IF EXTENDED.LOGGING THEN _ LOCATE 20,75 : _ PRINT "YES"; IF FMS.DIRECTORY$ <> "" THEN _ LOCATE 22,75 : _ PRINT "YES"; END SUB ' $SUBTITLE: 'BADCHAR - subroutine to check user names for bad characters' ' $PAGE ' ' SUBROUTINE NAME -- BADCHAR ' ' INPUT PARAMETERS -- PARAMETER MEANING ' PASSED.NAME$ USER NAME ' ' OUTPUT PARAMETERS -- PASSED.NAME$ USER NAME WILL CONTAIN "" ' IF BAD CHARACTERS FOUND ' ' SUBROUTINE PURPOSE -- TO CHECK USER NAMES FOR INVALID CHARACTERS ' SUB BADCHAR (PASSED.NAME$) STATIC ' J = 1 XX = LEN(PASSED.NAME$) 457 IF J > XX THEN _ EXIT SUB X = ASC(MID$(PASSED.NAME$,J,1)) IF (X < 65 OR X > 90) AND _ (X <> 32 AND X <> 39 AND X <> 45 AND X <> 46) THEN _ PASSED.NAME$ = "" : _ EXIT SUB J = J + 1 GOTO 457 END SUB ' $SUBTITLE: 'LINE25 - subroutine to build/display RBBS-PCs line 25' ' $PAGE ' ' SUBROUTINE NAME -- LINE25 ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER = 1 BUILD DISPLAY FOR LINE 25 ' SUBROUTINE.PARAMETER = 2 UPDATE LINE 25 ' LOCK.STATUS$ STATUS OF LOCKS IN A MULTI- ' USER ENVIRONMENT OR TIME OF ' DAY USER LOGGED ON OR THE ' RE-CYCLED ' ' OUTPUT PARAMETERS -- CURSOR.LINE CURRENT LINE ON SCREEN ' CURSOR.ROW CURRENT ROW ON CURSOR.LINE ' ' SUBROUTINE PURPOSE -- TO BUILD OR UPDATE RBBS-PC'S LINE 25 DISPLAYED ' ON THE PC SCREEN THAT IS RUNNING RBBS-PC. ' SUB LINE25 STATIC ON SUBROUTINE.PARAMETER GOTO 949,950 ' ' ***************************************************************************** ' * BUILD LINE 25 DISPLAY * ' ***************************************************************************** ' 949 LINE.25$ = MID$(" AVL ",1-4*SYSOP.AVAILABLE,4) + _ MID$(" ANY ",1-4*SYSOP.ANNOY,4) + _ MID$(" LPT ",1-4*PRINTER,4) + _ MID$("SYS",1,-3*SYSOP.NEXT) ' ' ***************************************************************************** ' * LINE 25 UPDATE ROUTINE * ' ***************************************************************************** ' 950 IF NOT SNOOP THEN _ EXIT SUB CURSOR.LINE = CSRLIN CURSOR.ROW = POS(0) HH = LEN(ACTIVE.USER.NAME$) + LEN(CI$) + LEN(LINE.25$) + 18 IF AUTODOWNLOAD.AVAILABLE THEN _ HH = HH + 4 LOCATE 25,1 IF NETWORK.TYPE = 0 THEN _ IF AUTODOWNLOAD.AVAILABLE THEN _ LOCK.STATUS$ = SPACE$(3) + _ "AD " + _ TIME.LOGGED.ON$ _ ELSE LOCK.STATUS$ = SPACE$(3)+TIME.LOGGED.ON$ IF HH>79 THEN _ HH=78 PRINT LINE.25$+SPACE$(79-HH)+STR$(USER.SECURITY.LEVEL)+" "+ACTIVE.USER.NAME$+" "+CI$+" "+LOCK.STATUS$; LOCATE CURSOR.LINE,CURSOR.ROW END SUB ' $SUBTITLE: 'SRCHCMND - subroutine to search command list' ' $PAGE ' ' SUBROUTINE NAME -- SRCHCMND ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRT.POS POSITION TO BEGIN SEARCH AT ' ALL.OPTS$ STRING TO SEARCH (COMMAND LIST) ' Z$ WHAT TO LOOK FOR ' ' OUTPUT PARAMETERS -- WHERE.FOUND POSITION OF Z$ IN ALL.OPTS$ ' 0 IF NOT FOUND ' ' SUBROUTINE PURPOSE -- SEARCHES VALID COMMAND LIST FOR THE REQUESTED ' COMMAND. IF THE SYSOP HAS CONFIGURED RBBS-PC TO ' RESTRICT COMMANDS TO ONLY THOSE VALID WITHIN THE ' RBBS-PC SUBSYSTEM, THEN ONLY THOSE COMMANDS AND ' "GLOBAL" COMMANDS ARE VALID. OTHERWISE ALL COMMANDS ' ARE VALID FROM ANY OF THE RBBS-PC SUBSYSTEMS. ' SUB SRCHCMND (STRT.POS,WHERE.FOUND) STATIC 1240 WHERE.FOUND = INSTR(STRT.POS,ALL.OPTS$,Z$) IF WHERE.FOUND = 0 THEN _ 'Not found: decide whether to hunt further IF STRT.POS < 2 OR RESTRICT.VALID.CMDS THEN _ EXIT SUB _ ' fully searched or restricted ELSE _ WHERE.FOUND = INSTR(1,ALL.OPTS$,Z$) : _ 'hunt further EXIT SUB IF NOT RESTRICT.VALID.CMDS THEN _ EXIT SUB ' everything found valid ' ' ***************************************************************************** ' * RESTRICT COMMANDS TO SUBSYSTEMS (EXCEPT GLOBAL AND SYSOP) * ' ***************************************************************************** ' IF WHERE.FOUND > LEN(ALL.OPTS$)-11 THEN _ EXIT SUB ' ACCEPT GLOBAL & SYSOP IF MID$(ALL.OPTS$,WHERE.FOUND,1) = "G" THEN _ EXIT SUB ' ACCEPT GOODBYE/GRAPHICS IF (STRT.POS < BEG.FILE AND WHERE.FOUND >= BEG.FILE ) OR _ (STRT.POS < BEG.UTIL AND WHERE.FOUND >= BEG.UTIL ) THEN _ WHERE.FOUND = 0 ' REJECT: NOT IN SECTION END SUB ' $SUBTITLE: 'HELP - Processes requests for help' ' $PAGE ' ' SUBROUTINE NAME -- HELP ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SECTION ORDER OF 1ST COMMAND IN CURRENT ' SECTION ' GRAPHICS.DEFAULT WHAT GRAPHICS TYPE USER WANTS ' HELP.DEFAULT$ HELP GET IF PRESS ENTER ' HELP.PATH$ ' HELP.EXTENSION$ ' BEG.FILE ' BEG.MAIN ' BEG.UTIL ' ' OUTPUT PARAMETERS -- DISPLAYS HELP ' ' SUBROUTINE PURPOSE -- THE MAIN HELP PROCESSOR FOR RBBS. PUTS UP THE ' OPTIONAL MENU. ACCEPTS HELP WITH INDIVIDUAL SUB HELP (SECTION,GRAPHIC.DEFAULT$,HELP.DEFAULT$) STATIC 1330 HELP.MENU$ = HELP.PATH$+"HELP"+HELP.EXTENSION$ GOT.MENU = TRUE IF Q>1 THEN _ ANS.INDEX = 2 : _ LAST.INDEX = Q: _ GOTO 1332 1331 IF GOT.MENU THEN _ FILE.NAME$ = HELP.MENU$ : _ GOSUB 1350 : _ GOT.MENU = OK ANS.INDEX = 1 A$ = "HELP with (LETTER/SECTION/TOPIC, [ENTER]="+HELP.DEFAULT$+", [QH]=quit HELP)" SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF Q = 0 THEN _ Q = 1:_ B$(1) = HELP.DEFAULT$ LAST.INDEX = Q 1332 Z$ = B$(ANS.INDEX) CALL ALLCAPS (Z$) IF Z$="QH" THEN _ EXIT SUB IF Z$ = "?" THEN _ Z$ = "H" CALL BADFILE (Z$,BAD.FILE.NAME.INDEX) ON BAD.FILE.NAME.INDEX GOTO 1333,1340,1340 1333 IF LEN(Z$) = 1 THEN _ CALL SRCHCMND (SECTION,FF) : _ IF FF<1 THEN _ OK = FALSE :_ GOTO 1334 _ ELSE X = -(FF>=BEG.MAIN)-(FF>=BEG.FILE)-(FF>=BEG.UTIL):_ Z$ = MID$("MFU",X,1) + Z$ FILE.NAME$ = HELP.PATH$ + Z$ + HELP.EXTENSION$ GOSUB 1350 1334 IF NOT OK THEN _ A$ = "No help for "+Z$ :_ CALL QTPUT (A$,1) : _ CALL UPDTCALR (A$,2) ANS.INDEX = ANS.INDEX + 1 IF ANS.INDEX <= LAST.INDEX THEN _ GOTO 1332 GOTO 1331 1340 OK = FALSE GOTO 1334 1350 CALL GRAPHIC (GRAPHIC.DEFAULT$) CALL BUFFILE (FILE.NAME$) RETURN END SUB ' $SUBTITLE: 'QTPUT - subroutine to quickly write to terminal' ' $PAGE ' ' SUBROUTINE NAME -- QTPUT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ STRING TO WRITE OUT ' NUM.RETURNS NUMBER OF CARRIAGE RETURNS ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO QUICKLY WRITE TO THE TERMINAL. THIS IS ' IS DIFFERENT FROM "TPUT" IN THE THINGS IT DOESN'T DO: ' A.) NO FUNCTION KEY CHECK, ' B.) NO CONVERSION TO UPPER CASE, ' C.) NO STRING RE-INITILIZATION OF "STRNG$", ' D.) NO CHECK FOR CARRIER PRESENT, AND ' E.) NO CHECK FOR IMBEDDED CARRIAGE RETURN IN ' "STRNG$". ' F.) NO SUPPORT FOR XON/XOFF ' SUB QTPUT (STRNG$,NUM.RETURNS) STATIC IF UPPER.CASE THEN _ GOTO 1476 IF COLOR.SUPPORT THEN _ IF SNOOP THEN _ GOTO 1476 IF NOT LOCAL.USER THEN _ PRINT #3,STRNG$; IF SNOOP THEN _ PRINT STRNG$; CALL SKIPLINE (NUM.RETURNS) GOTO 1477 1476 A$ = STRNG$ SUBROUTINE.PARAMETER = 4 CALL TPUT CALL SKIPLINE (NUM.RETURNS) 1477 END SUB ' $SUBTITLE: 'PRTCRLF - subroutine to write snoop lines' ' $PAGE ' ' SUBROUTINE NAME -- PRTCRLF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ STRING TO WRITE TO SCREEN ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO WRITE OUT LINES TO THE LOCAL SYSOP'S SCREEN THAT ' MAY HAVE INTERNAL CARRIAGE RETURN AND LINE FEEDS ' IMBEDDED IN IT. ' SUB PRTCRLF (STRNG$) STATIC 1478 CURSOR.ROW = 1 L = LEN(STRNG$) NUM.RETURNS = 0 WHILE CURSOR.ROW <= L CURSOR.LINE = CURSOR.ROW + _ INSTR(MID$(STRNG$,CURSOR.ROW) + _ CARRIAGE.RETURN$,CARRIAGE.RETURN$) - 2 S1 = -(CURSOR.LINE < L) PRINT MID$(STRNG$,CURSOR.ROW,CURSOR.LINE-CURSOR.ROW + 1); _ MID$(LINE.FEED$,1,S1); CURSOR.ROW = CURSOR.LINE + LEN(RETURN.LINE.FEED$) + 1 NUM.RETURNS = NUM.RETURNS + S1 WEND END SUB ' $SUBTITLE: 'SKIPLINE - subroutine to write a blank line to user' ' $PAGE ' ' SUBROUTINE NAME -- SKIPLINE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LOCAL.USER ' MODEM.STATUS.REGISTER ' NUM.RETURNS ' RETURN.LINE.FEED$ ' SNOOP ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- SKIP A LINE ON THE USER'S TERMINAL ' SUB SKIPLINE (NUM.RETURNS) STATIC 1485 IF NOT LOCAL.USER AND INP(MODEM.STATUS.REGISTER) > 127 THEN _ FOR I=1 TO NUM.RETURNS:PRINT #3,RETURN.LINE.FEED$;:NEXT IF SNOOP THEN _ FOR I=1 TO NUM.RETURNS:PRINT:NEXT LINES.PRINTED = LINES.PRINTED + NUM.RETURNS END SUB ' $SUBTITLE: 'SETCRLF -- subroutine to set up nulls/lf's for output' ' $PAGE ' ' SUBROUTINE NAME -- SETCRLF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' CARRIAGE.RETURN$ CARRIAGE RETURN CHARACTER ' CI$ CITY/STATE OF CALLER ' LINE.FEED$ LINE FEED CHARACTER ' LINE.FEEDS LINE FEED SWITCH ' NUL$ NULL CHARACTER ' ' OUTPUT PARAMETERS -- RETURN.LINE.FEED$ END-OF-LINE STRING ' ' SUBROUTINE PURPOSE -- SET UP THE NECESSARCY NULLS/LINE FEEDS TO END ' EACH OUTPUT TO THE COMMUNICATIONS PORT WITH ' SUB SETCRLF STATIC 1496 RETURN.LINE.FEED$ = MID$(CARRIAGE.RETURN$,1,-(NOT LOCAL.USER)) + _ NUL$ + _ MID$(LINE.FEED$,1,-(LINE.FEEDS <> 0)) END SUB ' $SUBTITLE: 'SETBAUD - subroutine to set the baud rate in the RS232' ' $PAGE ' ' SUBROUTINE NAME -- SETBAUD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BAUD.RATE.DIVISOR NUMBER TO DIVIDE THE 8250 CHIP'S ' PROGRAMABLE CLOCK TO ADJUST THE ' BAUD RATE TO THE USER'S BAUD ' RATE (INDEPENDENT OF THE BAUD ' RATE USED TO OPEN THE COMM. PORT) ' ' DESIRED BAUD DIVISIOR (DECIMAL) TO OBTAIN DESIRED BAUD RATE ' RATE PCjr PC AND XT ' 50 2237 2304 ' 75 1491 1536 ' 110 1017 1047 ' 134.5 832 857 ' 150 746 768 ' 300 373 384 ' 600 186 192 ' 1200 93 96 ' 1800 62 64 ' 2000 56 58 ' 2400 47 48 ' 3600 31 32 ' 4800 23 24 ' 7200 not available 16 ' 9600 not available 12 ' ' OUTPUT PARAMETERS -- BAUD RATE SET IN THE RS232 INTERFACE ' ' SUBROUTINE PURPOSE -- TO SET THE BAUD RATE IN THE RS232 INTERFACE ' INDEPENDENT OF THE BAUD RATE THE COMMUNICATIONS PORT ' WAS OPENED AT ' SUB SETBAUD STATIC ' ' ***************************************************************************** ' * BAUD RATE CHANGE ROUTINE * ' ***************************************************************************** ' 1654 LINE.CONTROL.STATUS = INP(LINE.CONTROL.REGISTER) MSB.SAVE = INP(MSB) OUT MSB,0 OUT LINE.CONTROL.REGISTER,LINE.CONTROL.STATUS OR 128 MOST.SIGNIFICANT.BYTE = FIX (BAUD.RATE.DIVISOR / 256) LEAST.SIGNIFICANT.BYTE = BAUD.RATE.DIVISOR - (MOST.SIGNIFICANT.BYTE * 256) OUT LSB,LEAST.SIGNIFICANT.BYTE OUT MSB,MOST.SIGNIFICANT.BYTE OUT LINE.CONTROL.REGISTER,LINE.CONTROL.STATUS OUT MSB,MSB.SAVE END SUB ' $SUBTITLE: 'KILLMSG - subroutine to delete messages' ' $PAGE ' ' SUBROUTINE NAME -- KILLMSG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' MESSAGE.TO.KILL MESSAGE NUMBER TO KILL ' ACTIVE.MESSAGES NUMBER ACTIVE MESSAGES ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO KILL/DELETE OLD OR UNNECESSARY MESSAGES ' SUB KILLMSG (MESSAGE.TO.KILL,ACTIVE.MESSAGES) STATIC ' FIELD #1,128 AS MESSAGE.RECORD$ QX = 1 3955 IF QX > ACTIVE.MESSAGES THEN _ A$ = "No such msg #" + STR$(MESSAGE.TO.KILL) : _ GOTO 4031 IF M(QX,2) = MESSAGE.TO.KILL AND MESSAGE.TO.KILL >= 1 THEN _ GOTO 3970 QX = QX + 1 GOTO 3955 3970 SUBROUTINE.PARAMETER = 3 CALL FILELOCK GET 1,M(QX,1) IF SYSOP THEN _ GOTO 4030 3980 Z$ = MID$(MESSAGE.RECORD$,101,15) Z$ = LEFT$(Z$ + SPACE$(2),INSTR(Z$ +SPACE$(2),SPACE$(2))-1) IF LEN(Z$) = 0 THEN _ GOTO 4030 3990 IF Z$ = "^READ^" OR Z$ = "^KILL^" THEN _ IF INSTR(MESSAGE.RECORD$,ACTIVE.USER.NAME$) THEN _ GOTO 4030 _ ELSE MESSAGE.PASSWORD = TRUE : _ ATTEMPTS.ALLOWED = 0 : _ CALL QTPUT("Only sender & receiver can kill",1): _ GOTO 4031 4000 IF LEFT$(Z$,1) = "!" THEN _ Z$ = MID$(Z$,2) 4010 PASSWORD.SAVE$ = Z$ + SPACE$(15-LEN(Z$)) ATTEMPTS.ALLOWED = 1 MESSAGE.PASSWORD = TRUE CALL PASSWORD IF PASSWORD.FAILED THEN _ GOTO 4031 4030 LSET MESSAGE.RECORD$ = LEFT$(MESSAGE.RECORD$,115) + _ DELETED.MESSAGE$ + _ MID$(MESSAGE.RECORD$,117) PUT 1,LOC(1) A$ = "Killed Msg # " + STR$(MESSAGE.TO.KILL) SUBROUTINE.PARAMETER = 4 CALL FILELOCK SUBROUTINE.PARAMETER = 5 CALL TPUT EXIT SUB 4031 SUBROUTINE.PARAMETER = 4 CALL TPUT END SUB ' $SUBTITLE: 'GETIME - subroutine to calculate elapsed time' ' $PAGE ' ' SUBROUTINE NAME -- GETIME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TIME.LOGGED.ON$ ' ' OUTPUT PARAMETERS -- HH NUMBER OF HOURS ON ' MM NUMBER OF MINUTES ON ' SS NUMBER OF SECONDS ON ' ' SUBROUTINE PURPOSE -- CALCULATE THE ELASPED TIME A USER HAS BEEN ON ' SUB GETIME STATIC 9140 H = VAL(MID$(TIME.LOGGED.ON$,1,2)) M = VAL(MID$(TIME.LOGGED.ON$,4,2)) S = VAL(MID$(TIME.LOGGED.ON$,7,2)) X$ = TIME$ HH = VAL(MID$(X$,1,2)) MM = VAL(MID$(X$,4,2)) JJ = VAL(MID$(X$,7,2)) IF S <= JJ THEN _ SSS = JJ-S _ ELSE SSS = 60-(S-JJ) : _ M = M + 1 9150 IF M <= MM THEN _ MMM = MM-M _ ELSE MMM = 60-(M-MM) : _ H = H + 1 9160 IF H <= HH THEN _ HHH = HH-H : _ GOTO 9161 _ ELSE HHH = 24-(H-HH) 9161 END SUB ' $SUBTITLE: 'DEFAULTU - subroutine to update user defauts' ' $PAGE ' ' SUBROUTINE NAME -- DEFAULTU ' ' INPUT PARAMETERS -- PARAMETER MEANING ' AUTODOWNLOAD.AVAILABLE ' CHECK.BULLETIN.LOGON ' EXPERT.USER ' GR ' LAST.MESSAGE.READ ' LINE.FEEDS ' NULLS ' PAGE.LENGTH ' PROMPT.BELL ' REG.DATE$ ' REQ.QUES.ANSWERED ' RIGHT.MARGIN ' SKIP.FILES.LOGON ' TIMES.LOGGED.ON ' UPPER.CASE ' USER.OPTIONS$ ' USER.TRANSFER.DEFAULT$ ' ' OUTPUT PARAMETERS -- USER.OPTONS$ ' ' SUBROUTINE PURPOSE -- TO UPDATE THE USER'S RECORD WITH THEIR OPTIONS ' SUB DEFAULTU STATIC ' ' ***************************************************************************** ' * UPDATE USER DEFAULTS * ' ***************************************************************************** ' 9600 LSET USER.OPTIONS$ = _ MKI$(TIMES.LOGGED.ON) + _ MKI$(LAST.MESSAGE.READ) + _ USER.TRANSFER.DEFAULT$ + _ MID$(STR$(GR),2,1) + _ MKI$(RIGHT.MARGIN) + _ MKI$(-PROMPT.BELL-2*EXPERT.USER-4*NULLS-8*UPPER.CASE-16*LINE.FEEDS_ -32*CHECK.BULLETIN.LOGON - 64*SKIP.FILES.LOGON_ -128*AUTODOWNLOAD.AVAILABLE - 256*REQ.QUES.ANSWERED) + _ REG.DATE$ + _ CHR$(PAGE.LENGTH) + _ STRING$(1,0) END SUB ' $SUBTITLE: 'RECOVMSG - subroutine to recover deleted messages' ' $PAGE ' ' SUBROUTINE NAME -- RECOVMSG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' MESSAGE.TO.RECOVER MESSAGE NUMBER TO RECOVER ' FIRST.MESSAGE.RECORD RECORD # FOR FIRST MSG ' ' OUTPUT PARAMETERS -- ACTION.FLAG SET TO 0 IF ERROR ' SET TO -1 IF NO ERROR ' ' SUBROUTINE PURPOSE -- TO RECOVER DELETED MESSAGES. NOTE THAT THIS IS ONLY ' POSSIBLE IF YOU HAVE NOT COMPRESSED YOUR MESSAGE FILE ' USING CONFIG. SUB RECOVMSG (MESSAGE.TO.RECOVER,FIRST.MESSAGE.RECORD,ACTION.FLAG) STATIC FIELD #1,128 AS MESSAGE.RECORD$ 10410 MESSAGE.RECORD = FIRST.MESSAGE.RECORD SUBROUTINE.PARAMETER = 5 CALL TPUT 10420 GET 1,MESSAGE.RECORD NUMBER.RECORDS.IN.MESSAGE = VAL(MID$(MESSAGE.RECORD$,117,4)) IF NUMBER.RECORDS.IN.MESSAGE < 1 THEN _ A$ = "USE CONFIG TO REPAIR YOUR MESSAGE FILE" : _ SUBROUTINE.PARAMETER = 5 : _ GOTO 10485 IF MESSAGE.RECORD >= NEXT.MESSAGE.RECORD THEN _ A$ = "No Msg #" + STR$(MESSAGE.TO.RECOVER) : _ GOTO 10485 10440 IF VAL(MID$(MESSAGE.RECORD$,2,4)) <> MESSAGE.TO.RECOVER THEN _ MESSAGE.RECORD = MESSAGE.RECORD + NUMBER.RECORDS.IN.MESSAGE : _ GOTO 10420 10450 IF INSTR(MESSAGE.RECORD$,DELETED.MESSAGE$) <> 0 THEN _ SUBROUTINE.PARAMETER = 3 : _ CALL TPUT : _ LSET MESSAGE.RECORD$ = LEFT$(MESSAGE.RECORD$,115) + _ ACTIVE.MESSAGE$ + _ MID$(MESSAGE.RECORD$,117) : _ PUT 1,LOC(1) : _ SUBROUTINE.PARAMETER = 4 : _ CALL TPUT : _ A$ = "Restored Msg #" + STR$(MESSAGE.TO.RECOVER) : _ ACTION.FLAG = TRUE : _ GOTO 10485 10480 A$ = "Msg #" + STR$(MESSAGE.TO.RECOVER) + " not Dead" 10485 SUBROUTINE.PARAMETER = 5 CALL TPUT END SUB ' $SUBTITLE: 'UPDATEU -- Update the users record at logoff' ' $PAGE ' SUBROUTINE NAME -- UPDATEU ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ADJUSTED.SECURITY ' CURRENT.DATE$ ' DOWNLOADS ' ELAPSED.TIME ' LIST.DIRECTORY ' MAIN.USER.FILE.INDEX ' SECONDS.PER.SESSION! ' UPLOADS ' USER.SECURITY.LEVEL ' ' OUTPUT PARAMETERS -- ELAPSED.TIME$ ' LIST.NEW.DATE$ ' SECURITY.LEVEL$ ' USER.DOWNLOADS$ ' USER.UPLOADS$ ' ' SUBROUTINE PURPOSE -- UPDATE THE USER RECORD FOR THE USER WHEN THE USER ' EXITS RBBS-PC. ' SUB UPDATEU STATIC 10600 USER.FILE.INDEX = MAIN.USER.FILE.INDEX SUBROUTINE.PARAMETER = 6 CALL FILELOCK CALL OPENUSER FIELD 5,31 AS USER.NAME$, _ 15 AS PASSWORD$, _ 2 AS SECURITY.LEVEL$, _ 14 AS USER.OPTIONS$, _ 24 AS CITY.STATE$, _ 19 AS MACHINE.TYPE$, _ 14 AS LAST.DATE.TIME.ON$, _ 3 AS LIST.NEW.DATE$, _ 2 AS USER.DOWNLOADS$, _ 2 AS USER.UPLOADS$, _ 2 AS ELAPSED.TIME$ 10604 GET 5,USER.FILE.INDEX CALL DEFAULTU IF LIST.DIRECTORY THEN _ LSET LIST.NEW.DATE$ = CHR$(VAL(MID$(CURRENT.DATE$,7,2)))+_ CHR$(VAL(MID$(CURRENT.DATE$,1,2)))+_ CHR$(VAL(MID$(CURRENT.DATE$,4,2))) 10605 LSET USER.DOWNLOADS$ = MKI$(DOWNLOADS) LSET USER.UPLOADS$ = MKI$(UPLOADS) CALL TIMEREMAIN (TIME.REMAINING!) LSET ELAPSED.TIME$ = MKI$(ELAPSED.TIME + _ (SECONDS.PER.SESSION! / 60) - _ TIME.REMAINING!) IF ADJUSTED.SECURITY THEN _ LSET SECURITY.LEVEL$ = MKI$(USER.SECURITY.LEVEL) PUT 5,USER.FILE.INDEX END SUB ' $SUBTITLE: 'DOSEXIT -- Setup to exit to DOS for SYSOP' ' $PAGE ' SUBROUTINE NAME -- DOSEXIT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' COM.PORT$ ' DOORS.TERMINAL.TYPE ' MULTI.LINK.PRESENT ' RBBS.BAT$ ' REDIRECT.IO.METHOD ' ' OUTPUT PARAMETERS -- Q NUMBER OF LINES TO WRITE OUT TO ' RCTTY.BAT$ ' B$() LINES TO WRITE OUT TO RCTTY.BAT$ ' ' SUBROUTINE PURPOSE -- SET UP B$() AND Q IN ORDER TO CALL "RBBSEXIT" AND ' EXIT TO DOS FOR THE REMOTE RBBS-PC SYSOP ' SUB DOSEXIT STATIC 10934 IF MULTI.LINK.PRESENT AND _ DOORS.TERMINAL.TYPE > 0 THEN _ FF = 0 : _ GOTO 10950 A$(1) = "ECHO OFF" IF REDIRECT.IO.METHOD THEN _ FF = 5 : _ A$(2) = "CTTY " + COM.PORT$ : _ A$(3) = DISK.FOR.DOS$ + "COMMAND" : _ A$(4) = "CTTY CON" : _ A$(5) = RBBS.BAT$ _ ELSE _ FF = 3 : _ A$(2) = DISK.FOR.DOS$ + "COMMAND >" + COM.PORT$ + " <" + COM.PORT$ : _ A$(3) = RBBS.BAT$ 10950 SUBROUTINE.PARAMETER = 1 CALL AMORPM CALL UPDTCALR ("Exited to DOS at " + TIM$,2) CALL QTPUT("RBBS-PC " + VERSION.ID$,1) CALL QTPUT("SYSOP in Remote Console Mode",1) CALL RBBSEXIT (A$(),FF) END SUB ' $SUBTITLE: 'WORDINFILE -- Searches a file to find a word' ' $PAGE ' SUBROUTINE NAME -- WORDINFILE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILNAME$ FILE TO SEARCH IN ' STRNG$ STRING TO SEARCH FOR ' ' OUTPUT PARAMETERS -- INFILE WHETHER STRING FOUND IN FILE ' ' SUBROUTINE PURPOSE -- SEARCHES FOR "STRNG$" IN FILE "FILNAME$." USED TO ' LIMIT DOORS AND QUESTIONNAIRES TO THOSE SPECIFIED ' IN THEIR MENU FILES. THE "STRNG$" IS CAPITALIZED ' BUT NOT THE LINES IN THE FILE, SO MUST BE EXACT ' CASE-SENSITIVE MATCH TO BE FOUND. THE ONLY CHARACTER ' THAT CAN IMMEDIATELY PROCEED OR END A NAME TO BE ' FOUND MUST BE A BLANK. ' SUB WORDINFILE (FILNAME$,STRNG$,INFILE) STATIC 10976 INFILE = FALSE CALL FINDIT (FILNAME$) IF NOT OK THEN _ EXIT SUB X = 0 CALL ALLCAPS (STRNG$) WHILE NOT EOF(2) AND X < 1 LINE INPUT #2,A$ Y = 1 10978 X = INSTR(Y,A$,STRNG$) IF X < 1 THEN _ GOTO 10980 Y = X+1 IF X>1 THEN _ IF MID$(A$,X-1,1)<>" " THEN _ X=0 IF X>0 THEN _ L = LEN(STRNG$) : _ IF LEN(A$) >= (X+L) THEN _ IF MID$(A$,X+L,1)<>" " THEN _ X=0 IF X=0 THEN _ GOTO 10978 10980 WEND CLOSE 2 INFILE = (X > 0) END SUB ' $SUBTITLE: 'DOOREXIT -- Setup to exit to a "door"' ' $PAGE ' SUBROUTINE NAME -- DOOREXIT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' MULTI.LINK.PRESENT ' NODE.ID$ ' RBBS.BAT$ ' Z$ ' ' OUTPUT PARAMETERS -- Q NUMBER OF LINES TO WRITE OUT TO ' RCTTY.BAT$ ' B$() LINES TO WRITE OUT TO RCTTY.BAT$ ' ' SUBROUTINE PURPOSE -- SET UP B$() AND Q IN ORDER TO CALL "EXITRBBS" AND ' EXIT RBBS-PC TO INVOKE ANTOHER PROGRAM ' SUB DOOREXIT STATIC 10987 A$(1) = DISK.FOR.DOS$+ "COMMAND /C " + Z$ + NODE.ID$ A$(2) = RBBS.BAT$ A$ = Z$ + " door opened at " + TIME$ + " on " + DATE$ SUBROUTINE.PARAMETER = 5 CALL TPUT CALL UPDTCALR (LEFT$(Z$,LEN(Z$)-4) + " door opened!",2) CALL RBBSEXIT (A$(),2) END SUB ' $SUBTITLE: 'RBBSEXIT -- Setup to exit to a RBBS' ' $PAGE ' SUBROUTINE NAME -- RBBSEXIT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LINE.ARA Array of lines to write to batch file ' NUM.LINES How many lines in array ' ' OUTPUT PARAMETERS -- RCTTY.BAT$ ' ' SUBROUTINE PURPOSE -- TO CREATE A BATCH FILE THAT CONTROL CAN BE PASSED TO ' AND TO EXIT RBBS-PC WHILE STILL KEEPING CARRIER UP ' SUB RBBSEXIT (LINE.ARA$(1),NUM.LINES) STATIC 10992 CLOSE 2 IF NUM.LINES = 0 THEN _ GOTO 10994 OPEN "O",2,RCTTY.BAT$ FOR I = 1 TO NUM.LINES IF LINE.ARA$(I) <> "" THEN _ PRINT #2,LINE.ARA$(I) NEXT CLOSE 2 10994 CLOSE 3 EXIT.TO.DOORS = TRUE OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1 CALL MLINIT (2) 10996 IF NOT SYSOP THEN _ CALL UPDATEU : _ SUBROUTINE.PARAMETER = 8 : _ CALL FILELOCK CALL GETIME CALL UPDATEC CALL SAVEPROF (1) IF NUM.LINES = 0 THEN _ EXIT SUB SYSTEM END SUB ' $SUBTITLE: 'UNTILRIGHT - subroutine to ask question until answer okay' ' $PAGE ' ' SUBROUTINE NAME -- UNTILRIGHT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' QUES$ QUESTION TO BE ASKED THE USER ' ANS$ LOCATION TO STORE THE ANSWER ' MIN.LEN MINIMUM LENGTH OF ANSWER ' MAX.LEN MAX LENGTH OF ANSWER ' ' OUTPUT PARAMETERS -- ANS$ RESPONSE TO THE QUESTION WHICH THE ' CALLERS SAYS IS CORRECT ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO ASK A USER A QUESTION UNTIL THE CALLER ' RESPONDS THAT THE ANSWER IS CORRECT ' SUB UNTILRIGHT (QUES$,ANS$,MIN.LEN,MAX.LEN) STATIC 12880 SUBROUTINE.PARAMETER = 1 A$ = QUES$ CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 12882 IF Q=0 THEN _ GOTO 12880 IF LEN(B$(1))>MAX.LEN THEN _ CALL QTPUT (STR$(MAX.LEN)+" chars max",1) :_ GOTO 12880_ ELSE IF LEN(B$(1)) < MIN.LEN THEN_ CALL QTPUT (STR$(MIN.LEN)+" chars min",1) : _ GOTO 12880 ANS$ = B$(1) A$ = B$(1) + ", right (Y=[ENTER],N)" CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ GOTO 12882 IF NO THEN _ GOTO 12880 CALL ALLCAPS (ANS$) EXIT SUB 12882 ANS$ = "GUEST" END SUB ' $SUBTITLE: 'LOGERROR - subroutine to log errors to CALLERS file' ' $PAGE ' ' SUBROUTINE NAME -- LOGERROR ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ERR ERROR NUMBER DETECTED BY BASIC ' ERL LAST LINE NUMBER ENCOUNTERED ' PRIOR TO ENCOUNTERNING ERROR ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO SET UP A STRING TO WRITE TO THE CALLERS LOG ' INDICATING THE DATE, TIME, ERROR, AND ERROR LINE ' SUB LOGERROR STATIC 13660 CALL UPDTCALR("+++ Error " + _ STR$(ERR) + _ " line " + _ STR$(ERL) + _ " at " + _ TIME$ + _ " on " + _ DATE$,2) END SUB ' $SUBTITLE: 'BADNAME - subroutine to find bad file names' ' $PAGE ' ' SUBROUTINE NAME -- BADNAME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ACTIVE.MESSAGE.FILE$ ' ACTIVE.USER.FILE$ ' CALLERS.FILE$ ' COMMENTS.FILE$ ' CONFIG.FILEANAME$ ' MAIN.MESSAGE.BACKUP$ ' MAIN.MESSAGE.FILE$ ' MAXIMUM.VIOLATIONS ' PASSWORDS.FILE$ ' RBBS.BAT$ ' RCTTY.BAT$ ' SUBDIR$() ' SUBDIR.INDEX ' VIOLATION$ ' VIOLATIONS.THIS.SESSION ' Z$ NAME OF FILE ' ' OUTPUT PARAMETERS -- BAD.FILE.NAME.INDEX 1 = FILE NAME IS OK ' 2 = SECURITY BREACH TRIED ' VIOLATIONS.THIS.SESSION NUMBER OF VIOLATIONS ' FILENAME$ NAME OF FILE ' ' SUBROUTINE PURPOSE -- TO PROTECT RBBS-PC AGAINST THE USE OF BAD FILE NAMES ' TO EITHER CRASH THE SYSTEM OR TO BREACH RBBS-PC'S ' SECURITY ' SUB BADNAME STATIC ' ' ***************************************************************************** ' * TEST FOR SYSTEM FILE ATTEMPT * ' ***************************************************************************** ' 20235 BAD.FILE.NAME.INDEX = 1 Z$ = FILE.NAME$ IF INSTR(3,FILE.NAME$,MID$(ACTIVE.MESSAGE.FILE$,3,(LEN(ACTIVE.MESSAGE.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(ACTIVE.USER.FILE$,3,(LEN(ACTIVE.USER.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(ACTIVE.USER.FILE$+".BAK",3,(LEN(ACTIVE.USER.FILE$+".BAK")-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(CALLERS.FILE$,3,(LEN(CALLERS.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(COMMENTS.FILE$,3,(LEN(COMMENTS.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(FILESEC.FILE$,3,(LEN(FILESEC.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(MAIN.MESSAGE.BACKUP$,3,(LEN(MAIN.MESSAGE.BACKUP$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(MAIN.MESSAGE.FILE$,3,(LEN(MAIN.MESSAGE.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(MAIN.USER.FILE$,3,(LEN(MAIN.USER.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(MAIN.USER.FILE$+".BAK",3,(LEN(MAIN.USER.FILE$+".BAK")-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(PASSWORDS.FILE$,3,(LEN(PASSWORDS.FILE$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(RBBS.BAT$,3,(LEN(RBBS.BAT$)-2))) THEN _ GOTO 20236 IF INSTR(3,FILE.NAME$,MID$(RCTTY.BAT$,3,(LEN(RCTTY.BAT$)-2))) THEN _ GOTO 20236 CALL BRKFNAME (CONFIG.FILENAME$,DR$,PREFIX$,EXTENSION$,FALSE) IF INSTR(3,FILE.NAME$,MID$(CONFIG.FILENAME$,LEN(DR$)+1)) THEN _ GOTO 20236 EXIT SUB 20236 BAD.FILE.NAME.INDEX = 2 END SUB ' $SUBTITLE: 'BRKFNAME - subroutine to split file name into components' ' $PAGE ' ' SUBROUTINE NAME -- BRKFNAME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILENAME$ FULL NAME OF FILE ' FOR.JOINING TRUE IF WANT PARTS FORMATTED FOR ' FORMING FILE NAMES ' OUTPUT PARAMETERS -- DRVPATH$ DRIVE AND PATH ' PREFIX$ PREFIX OF FILE NAME ' EXTENSION$ EXTENSION OF FILE NAME ' ' (E.G. "C:\RBBS\ARCE.COM" HAS "C:\RBBS" AS DRIVE AND PATH, ' "ARCE" AS PREFIX OF THE FILE NAME, AND ' "COM" AS THE EXTENSION OF THE FILE NAME. ' ' JOINED FORMAT IS C:\RBBS\,ARCE,.COM ' ' SUBROUTINE PURPOSE -- TO BREAK A FILE NAME INTO ITS COMPONENT PARTS ' OF DRIVE/PATH, PREFIX, AND EXTENSION ' ' SUB BRKFNAME (FILENAME$,DRVPATH$,PREFIX$,EXTENSION$,FOR.JOINING) STATIC 20282 CALL ALLCAPS (FILENAME$) DRVPATH$ = "" PREFIX$ = "" EXTENSION$ = "" IF LEN(FILENAME$) < 1 THEN _ EXIT SUB CALL FINDLAST (FILENAME$,"\",X,Y) IF X < 1 THEN _ IF MID$(FILENAME$,2,1) = ":" THEN _ DRVPATH$ = LEFT$(FILENAME$,1): _ S = 3 _ ELSE S = 1 _ ELSE DRVPATH$ = LEFT$(FILENAME$,X-1) : _ S = X + 1 X = INSTR(FILENAME$+".",".") EXTENSION$ = MID$(FILENAME$,X+1,3) PREFIX$ = MID$(FILENAME$,S,X-S) IF NOT FOR.JOINING THEN _ EXIT SUB IF LEN(DRVPATH$) = 1 THEN _ DRVPATH$ = DRVPATH$ + ":" IF INSTR(DRVPATH$,"\") > 0 THEN _ DRVPATH$ = DRVPATH$ + "\" IF LEN(EXTENSION$) > 0 THEN _ EXTENSION$ = "." + EXTENSION$ END SUB ' $SUBTITLE: 'WILDCARD -- Matches string to a pattern' ' $PAGE ' SUBROUTINE NAME -- WILDCARD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' PATTERN$ PATTERN TO CHECK ' STRNG$ STRING TO FIE ' ' OUTPUT PARAMETERS -- OK TRUE IF MATCH FOUND ' FALSE IF NO MATCH WAS FOUND ' ' SUBROUTINE PURPOSE DETERMINE WHETHER A STRING IS AN INSTANCE IN A PATTERN ' SUPPORTED PATTERNS ARE ONLY "?" WHICH REQUIRES A ' CHARACTER BUT CAN BE ANY, AND "*" WHICH MATCHES ANY- ' THING, INCLUDING A NULL STRING. ANYTHING ELSE IN A ' MUST BE AN EXACT MATCH. ' SUB WILDCARD (PATTERN$,STRNG$) STATIC 20285 OK = TRUE K = 0 L = LEN(STRNG$) 20286 K = K + 1 IF K > L THEN _ GOTO 20288 B$ = MID$(PATTERN$,K,1) IF B$ = "*" THEN _ EXIT SUB 20287 IF B$ <> "?" AND MID$(STRNG$,K,1) <> B$ THEN _ OK = FALSE : _ EXIT SUB GOTO 20286 20288 IF L < LEN(PATTERN$) AND MID$(PATTERN$,L + 1,1) <> "*" THEN _ OK = FALSE END SUB ' $SUBTITLE: 'UPDTUPLOAD -- Updates upload directory' ' $PAGE ' SUBROUTINE NAME -- UPDTUPLOAD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILE.NAME$ ' UPLOAD.DIRECTORY$ ' FILE.NAME.HOLD$ ' SHARE.IT ' FMS.DIRECTORY$ ' Q! ' TCA! ' ' OUTPUT PARAMETERS -- BYTES.IN.FILE# ' SECONDS.PER.SESSION! ' ' SUBROUTINE PURPOSE -- UPON A SUCCESSFUL UPLOAD, ADD ENTRY TO THE UPLOAD ' DIRECTORY AND GIVE ANY SESSION TIME CREDIT. ' SUB UPDTUPLOAD (CATEGORY.NAME$(1),CATEGORY.CODE$(1)) STATIC 20705 CALL FINDIT (FILE.NAME$) IF NOT OK THEN _ BYTES.IN.FILE# = 0.0_ ELSE_ BYTES.IN.FILE# = LOF(2) IF BYTES.IN.FILE# < 1.0 THEN _ EXIT SUB ' C@FORMAT CALL QTPUT("Upload successful",1) X$ = DATE$ Z$ = LEFT$(X$,6) + RIGHT$(X$,2) STREW.TO$ = "" Y$ = "" 20710 CALL QTPUT("Describe " + FILE.NAME.HOLD$ + _ " (/ if for SYSOP only)",1) CALL QTPUT(LEFT$(" |----+---1+0---+---2+0---+---3+0---+---4+0---+-",_ MAX.DESC.LEN+3),1) A$="" SUBROUTINE.PARAMETER = 1 CALL TGET CALL CARRIER IF SUBROUTINE.PARAMETER = -1 THEN _ B$(1) = "<unavailable>": _ GOTO 20712 IF LEN(B$(1)) > MAX.DESC.LEN OR LEN(B$(1)) < 3 THEN _ GOTO 20710 20712 B$ = B$(1) DESC$ = B$ IF FMS.DIRECTORY$ <> UPLOAD.DIRECTORY$ THEN _ IF LEFT$(B$,1) = "/" THEN _ CALL UPDTCALR (B$,2) : _ GOTO 20726_ ELSE_ GOTO 20717 20715 IF LEFT$(B$,1) = "/" THEN _ B$ = MID$(B$(1),2) : _ Y$ = "***" : _ GOTO 20722 Y$ = DEFAULT.CATEGORY.CODE$ 20717 IF SUBROUTINE.PARAMETER = -1 OR _ USER.SECURITY.LEVEL < SL.CATEGORIZE.UPLOADS THEN _ GOTO 20722 20719 CALL BUFFILE (UPCAT.HELP$) 20720 A$ = "Upload best fits what category (H=help)" SUBROUTINE.PARAMETER = 1 CALL TGET IF SUBROUTINE.PARAMETER = -1 THEN _ B$ = DEFAULT.CATEGORY.CODE$ : _ GOTO 20722 IF Q = 0 THEN _ GOTO 20719 CALL ALLCAPS (B$(1)) IF B$(1) = "H" THEN _ GOTO 20719 CALL CHKNARY (B$(1),CATEGORY.NAME$(),NUM.CATEGORIES,FOUND) IF FOUND>0 THEN _ Y$ = CATEGORY.CODE$(FOUND) : _ IF LEN(Y$) > 0 AND LEN(Y$) < 4 AND INSTR(Y$,",")=0 THEN _ GOTO 20722 Y$ = "" IF NOT LIMIT.SEARCH.TO.FMS THEN _ STREW.TO$ = DIRECTORY.PATH$ + B$(1) + "." + DIRECTORY.EXTENTION$ : _ CALL FINDIT (STREW.TO$) : _ IF NOT OK THEN _ STREW.TO$ = "" CALL QTPUT ("No such category "+B$(1),1) GOTO 20719 20722 B$ = DESC$ EN$ = ALWAYS.STREW.TO$ GOSUB 20730 EN$ = STREW.TO$ GOSUB 20730 20725 EN$ = UPLOAD.DIRECTORY$ IF FMS.DIRECTORY$ = UPLOAD.DIRECTORY$ THEN _ B$ = DESC$ + SPACE$(MAX.DESC.LEN-LEN(DESC$)) + Y$ + SPACE$(3-LEN(Y$)) GOSUB 20730 20726 Y$ = " >> uploaded << " UPLOADS = UPLOADS + 1 CALL MUSIC (7) CALL TIMEREMAIN (TIME.REMAINING!) SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + _ UPLOAD.TIME.FACTOR! * _ (TCA!-Q!) EXIT SUB 20730 ' ---[ lock file ]--- IF EN$ = "" THEN _ RETURN BX = &H4 SUBROUTINE.PARAMETER = 9 CALL FILELOCK CLOSE 2 IF SHARE.IT THEN _ OPEN EN$ FOR APPEND SHARED AS #2 _ ELSE OPEN "A",2,EN$ ' ---[ append ]--- PRINT #2,USING "\ \######## & &"; _ FILE.NAME.HOLD$; _ BYTES.IN.FILE#; _ Z$; _ B$ CLOSE 2 ' ---[ unlock ]--- BX = &H4 SUBROUTINE.PARAMETER = 10 CALL FILELOCK RETURN END SUB ' $SUBTITLE: 'BADFILE - subroutine to find bad file names' ' $PAGE ' ' SUBROUTINE NAME -- BADFILE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' VIOLATION$ ' VIOLATIONS.THIS.SESSION ' FILNAME$ NAME OF FILE ' ' OUTPUT PARAMETERS -- RESULT 1 = FILE NAME IS OK ' 2 = CHARACTER NOT ALLOWED ' 3 = SYSTEM CRASH ATTEMPT ' VIOLATIONS.THIS.SESSION NUMBER OF VIOLATIONS ' FILNAME$ Gets capitalized ' ' SUBROUTINE PURPOSE -- TO PROTECT RBBS-PC AGAINST THE USE OF BAD FILE NAMES ' TO EITHER CRASH THE SYSTEM OR TO BREACH RBBS-PC'S ' SECURITY ' SUB BADFILE (FILNAME$,RESULT) STATIC ' ' ***************************************************************************** ' * TEST FOR INVALID CHARACTERS IN FILENAME * ' ***************************************************************************** ' 20741 RESULT = 1 IF LEN(FILNAME$) < 1 THEN _ RESULT = 2 : _ EXIT SUB CALL ALLCAPS (FILNAME$) IF INSTR(FILNAME$,"?") OR _ INSTR(FILNAME$,"*") OR _ INSTR(FILNAME$," ") OR _ INSTR(3,FILNAME$,":") OR _ INSTR(FILNAME$,".DEF") OR _ INSTR(FILNAME$,".OLD") OR _ MID$(FILNAME$,LEN(FILNAME$),1) = "." THEN _ RESULT = 2 : _ EXIT SUB FF = INSTR(FILNAME$,".") IF FF > 0 THEN _ FF = INSTR(FF+1,FILNAME$,".") : _ IF FF > 0 THEN _ RESULT = 2 : _ EXIT SUB FF = LEN(FILNAME$) IF FF >= 3 THEN _ IF INSTR("PRN:CON:AUX:NUL:",FILNAME$) THEN _ GOTO 20742 IF FF >= 4 THEN _ IF INSTR("COM1:COM2:LPT1:LPT2:LPT3:SCRN:KYBD:CONS:",FILNAME$) THEN _ GOTO 20742 IF FF > 12 THEN _ RESULT = 2 FG = INSTR(FILNAME$,".") IF FG = 0 AND FF > 8 THEN _ RESULT = 2 _ ELSE IF FG > 9 THEN _ RESULT = 2 EXIT SUB 20742 VIOLATIONS.THIS.SESSION = MAXIMUM.VIOLATIONS VIOLATION$ = VIOLATION$ + FILNAME$ RESULT = 3 END SUB ' $SUBTITLE: 'FILELOCK - subroutine to share RBBS-PC files' ' $PAGE ' ' SUBROUTINE NAME -- FILELOCK ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER = 1 UNLOCK USERS AND MESSAGES ' 2 FLUSH MESSAGE RECORD TO DISK ' AND UNLOCK MESSAGES ' 3 LOCK MESSAGE FILE ' 4 UNLOCK MESSAGE FILE ' 5 LOCK USER FILE ' 6 LOCK 4 RECORD BLOCK IN USER ' FILE ' 7 UNLOCK USER FILE ' 8 UNLOCK 4 RECORD BLOCK IN USER ' FILE ' 9 LOCK UPLOAD DIRECTORY OR ' COMMENTS FILE ' 10 UNLOCK UPLOAD DIRECTORY OR ' COMMENTS FILE ' ACTIVE.MESSAGE FILE$ NAME OF MESSAGE FILE ' ACTIVE.USER.FILE$ NAME OF USER FILE ' CONFIG.FILE.NAME$ FILE NAME TO FLUSH RECORD FROM ' EN$ UPLOAD DIRECTORY OR COMMENTS ' FILE NAME TO LOCK/UNLOCK ' NETWORK.TYPE TYPE OF NETWORK LOCKING TO USE ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = -1 TERMINATE RBBS-PC IMMEDATELY ' BLK ' LOCK.DRIVE ' LOCK.FILE.NAME$ ' LOCK.STATUS$ ' MESSAGE.FILE.LOCK ' USER.BLOCK.LOCK ' USER.FILE.LOCK ' USER.FILE.INDEX ' ' SUBROUTINE PURPOSE -- TO LOCK AND UNLOCK THE SHARED RBBS-PC FILES WHEN ' MULTIPLE COPIES OF RBBS-PC ARE SHARING THE SAME ' FILES IN EITHER A MULTI-TASKING DOS ENVIRONMENT OR ' IN A LOCAL AREA NETWORK ENVIRONMENT SUB FILELOCK STATIC ON SUBROUTINE.PARAMETER GOSUB 21995,21996,22000,25000,26000,26500,27000,_ 27500,29000,29500 EXIT SUB ' ' ***************************************************************************** ' * UNLOCK USERS AND MESSAGES * ' ***************************************************************************** ' 21995 GOSUB 27000 GOSUB 25000 RETURN ' ' ***************************************************************************** ' * FLUSH MESSAGE FILE DATA TO DISK BY OPENING DUMMY FILE # 1 * ' ***************************************************************************** ' 21996 CLOSE 1 IF SHARE.IT THEN _ OPEN CONFIG.FILENAME$ FOR INPUT SHARED AS #1 _ ELSE OPEN "I",1,CONFIG.FILENAME$ CLOSE 1 ' ' ***************************************************************************** ' * UNLOCK MESSAGES * ' ***************************************************************************** ' GOSUB 25000 RETURN ' ' ***************************************************************************** ' * LOCK MESSAGE FILE * ' ***************************************************************************** ' 22000 IF MESSAGE.FILE.LOCK = TRUE THEN _ RETURN MESSAGE.FILE.LOCK = TRUE MID$(LOCK.STATUS$,1,2) = "LM" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$ ON NETWORK.TYPE GOTO 22100,22200,22300,22400,22500 RETURN ' ' ***************************************************************************** ' * LOCK MESSAGE FILE (MULTI-LINK) * ' ***************************************************************************** ' 22100 AX = &H0 BX = &H1 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * LOCK MESSAGE FILE (OMNINET) * ' ***************************************************************************** ' 22200 CC$ = CHR$(1) + MID$(ACTIVE.MESSAGE.FILE$ + SPACE$(8),3,8) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 22200 ' ' ***************************************************************************** ' * LOCK MESSAGE FILE (ORCHID PC-NET) * ' * LOCK USER FILE (ORCHID PC-NET) * ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET) * ' ***************************************************************************** ' 22300 GOSUB 28100 CALL LPLKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ***************************************************************************** ' * LOCK SYSTEM (DESQview) * ' ***************************************************************************** ' 22400 AX = 1 BX = 0 CALL RBBSDV(AX,BX) RETURN ' ' ***************************************************************************** ' * LOCK MESSAGE FILE (10 NET) * ' * LOCK USER FILE (10 NET) * ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET) * ' ***************************************************************************** ' 22500 GOSUB 28100 CALL LPLK10(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ***************************************************************************** ' * UNLOCK MESSAGE FILE * ' ***************************************************************************** ' 25000 MESSAGE.FILE.LOCK = FALSE MID$(LOCK.STATUS$,1,2) = "UM" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$ ON NETWORK.TYPE GOTO 25100,25200,25300,25400,25500 RETURN ' ' ***************************************************************************** ' * UNLOCK MESSAGE FILE (MULTI-LINK) * ' ***************************************************************************** ' 25100 AX = &H100 BX = &H1 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * UNLOCK MESSAGE FILE (OMNINET) * ' ***************************************************************************** ' 25200 CC$ = CHR$(17) + MID$(ACTIVE.MESSAGE.FILE$ + SPACE$(8),3,8) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 25200 ' ' ***************************************************************************** ' * UNLOCK MESSAGE FILE (ORCHID PC-NET) * ' * UNLOCK USER FILE (ORCHID PC-NET) * ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET) * ' ***************************************************************************** ' 25300 GOSUB 28100 CALL UNLOKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ***************************************************************************** ' * UNLOCK SYSTEM (DESQview) * ' ***************************************************************************** ' 25400 AX = 2 BX = 0 CALL RBBSDV(AX,BX) RETURN ' ' ***************************************************************************** ' * UNLOCK MESSAGE FILE (10 NET) * ' * UNLOCK USER FILE (10 NET) * ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET) * ' ***************************************************************************** ' 25500 GOSUB 28100 CALL UNLOK10(LOCK.DRIVE,LOCK.FILE.NAME$,A) RETURN ' ' ***************************************************************************** ' * LOCK USER FILE * ' ***************************************************************************** ' 26000 IF USER.FILE.LOCK = TRUE THEN _ RETURN USER.FILE.LOCK = TRUE MID$(LOCK.STATUS$,4,2) = "LU" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.USER.FILE$ ON NETWORK.TYPE GOTO 26100,26200,22300,22400,22500 RETURN ' ' ***************************************************************************** ' * LOCK USER FILE (MULTI-LINK) * ' ***************************************************************************** ' 26100 AX = &H0 BX = &H2 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * LOCK USER FILE (OMNINET) * ' ***************************************************************************** ' 26200 CC$ = CHR$(1) + MID$(ACTIVE.USER.FILE$ + SPACE$(8),3,8) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 26200 ' ' ***************************************************************************** ' * LOCK 4 RECORD BLOCK IN USER FILE * ' ***************************************************************************** ' 26500 IF USER.BLOCK.LOCK = TRUE THEN _ RETURN USER.BLOCK.LOCK = TRUE BLK = (USER.FILE.INDEX / 4) + .26 MID$(LOCK.STATUS$,7,2) = "LB" SUBROUTINE.PARAMETER = 2 CALL LINE25 ON NETWORK.TYPE GOTO 26600,26700,26800,22400,26900 RETURN ' ' ***************************************************************************** ' * LOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK) * ' ***************************************************************************** ' 26600 AX = &H0 BX = BLK + 10 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * LOCK 4 RECORD BLOCK IN USER FILE (OMNINET) * ' ***************************************************************************** ' 26700 CC$ = CHR$(1) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOSUB 28000 IF CT = 0 THEN _ RETURN CALL DELAYIT (1) GOTO 26700 ' ' ***************************************************************************** ' * LOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET) * ' ***************************************************************************** ' 26800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 22300 ' ' ***************************************************************************** ' * LOCK 4 RECORD BLOCK IN USER FILE (10 NET) * ' ***************************************************************************** ' 26900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 22500 ' ' ***************************************************************************** ' * UNLOCK USER FILE * ' ***************************************************************************** ' 27000 USER.FILE.LOCK = FALSE MID$(LOCK.STATUS$,4,2) = "UU" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = ACTIVE.USER.FILE$ ON NETWORK.TYPE GOTO 27100,27200,25300,25400,25500 RETURN ' ' ***************************************************************************** ' * UNLOCK USER FILE (MULTI-LINK) * ' ***************************************************************************** ' 27100 AX = &H100 BX = &H2 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * UNLOCK USER FILE (OMNINET) * ' ***************************************************************************** ' 27200 CC$ = CHR$(17) + MID$(ACTIVE.USER.FILE$ + SPACE$(8),3,8) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 27200 ' ' ***************************************************************************** ' * UNLOCK 4 RECORD BLOCK IN USER FILE * ' ***************************************************************************** ' 27500 USER.BLOCK.LOCK = FALSE BLK = (USER.FILE.INDEX / 4) + .26 MID$(LOCK.STATUS$,7,2) = "UB" SUBROUTINE.PARAMETER = 2 CALL LINE25 ON NETWORK.TYPE GOTO 27600,27700,27800,25400,27900 RETURN ' ' ***************************************************************************** ' * UNLOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK) * ' ***************************************************************************** ' 27600 AX = &H100 BX = BLK + 10 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * UNLOCK 4 RECORD BLOCK IN USER FILE (OMNINET) * ' ***************************************************************************** ' 27700 CC$ = CHR$(17) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOSUB 28000 IF CT = 128 THEN _ RETURN CALL DELAYIT (1) GOTO 27700 ' ' ***************************************************************************** ' * UNLOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET) * ' ***************************************************************************** ' 27800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 25300 ' ' ***************************************************************************** ' * UNLOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET) * ' ***************************************************************************** ' 27900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5) GOTO 25500 ' ' ***************************************************************************** ' * CORVUS OMNINET INTERFACE * ' ***************************************************************************** ' 28000 CC$ = LINE.FEED$ + CHR$(0) + CHR$(11) + CC$ CALL CDSEND(CC$) CALL CDRECV(CN$) CT = ASC(MID$(CN$,3,1)) IF CT >= 128 THEN _ PRINT "CORVUS LOCK FAIL" : _ SUBROUTINE.PARAMETER = -1 28010 CT = ASC(MID$(CN$,4,1)) IF CT >= 129 THEN _ PRINT "CORVUS FULL" : _ SUBROUTINE.PARAMETER = -1 RETURN ' ' ***************************************************************************** ' * ORCHID PC-NET & 10 NET INTERFACE * ' ***************************************************************************** ' 28100 CALL ALLCAPS (LOCK.FILE.NAME$) LOCK.DRIVE = ASC(LEFT$(LOCK.FILE.NAME$,1))-ASC("A") LOCK.FILE.NAME$ = LOCK.FILE.NAME$ + _ STRING$(32-LEN(LOCK.FILE.NAME$),0) A = 0 RETURN ' ' ***************************************************************************** ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ * ' ***************************************************************************** ' 29000 MID$(LOCK.STATUS$,10,2) = "LD" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = EN$ ON NETWORK.TYPE GOTO 29100,29010,22300,22400,22500 29010 RETURN ' ' ***************************************************************************** ' * LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK) * ' ***************************************************************************** ' 29100 AX = &H0 BX = &H3 CALL RBBSML(AX,BX) RETURN ' ' ***************************************************************************** ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ * ' ***************************************************************************** ' 29500 MID$(LOCK.STATUS$,10,2) = "UD" SUBROUTINE.PARAMETER = 2 CALL LINE25 LOCK.FILE.NAME$ = EN$ ON NETWORK.TYPE GOTO 29600,29510,25300,25400,25500 29510 RETURN ' ' ***************************************************************************** ' * UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK) * ' ***************************************************************************** ' 29600 AX = &H100 BX = &H3 CALL RBBSML(AX,BX) EXIT SUB END SUB ' $SUBTITLE: 'OPENMSG - open the MESSAGES file' ' $PAGE ' ' SUBROUTINE NAME -- OPENMSG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ACTIVE.MESSAGE.FILE$ ' SHARE.IT ' ' OUTPUT PARAMETERS -- MESSAGE.RECORD$ ' SUB OPENMSG STATIC ' ' ***************************************************************************** ' * OPEN AND DEFINE MESSAGE FILE * ' ***************************************************************************** ' 30500 CLOSE 1 IF SHARE.IT THEN _ OPEN ACTIVE.MESSAGE.FILE$ FOR RANDOM SHARED AS #1 _ ELSE OPEN "R",1,ACTIVE.MESSAGE.FILE$ FIELD 1,128 AS MESSAGE.RECORD$ END SUB ' $SUBTITLE: 'TIMEREMAIN - calculates time remaining in a session' ' $PAGE ' ' SUBROUTINE NAME -- TIMEREMAIN ' ' INPUT PARAMETERS -- PARAMETER MEANING ' USER.LOGON.TIME! ' SECONDS.PER.SESSION! ' BYPASS.TIME.CHECK ' OUTPUT PARAMETERS -- PARAMETER MEANING ' TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION ' TCA! TIME USED IN SECONDS SUB TIMEREMAIN (TIME.REMAINING!) STATIC 41010 TOA! = FRE("A") IF BYPASS.TIME.CHECK THEN _ TIME.REMAINING! = SECONDS.PER.SESSION! : _ EXIT SUB CALL FINDTIME (TI!) IF TI! > USER.LOGON.TIME! THEN _ CALL FINDTIME (TCA!) : _ TCA! = TCA! - USER.LOGON.TIME! _ ELSE CALL FINDTIME (TI!) : _ TCA! = TI! + 86400! - USER.LOGON.TIME! TIME.REMAINING! = (SECONDS.PER.SESSION!-TCA!) / 60 TIME.REMAINING! = -(TIME.REMAINING! > 0.0)*TIME.REMAINING! END SUB ' ' ***************************************************************************** ' * SUBROUTINE TO CALCULATE AND DISPLAY THE TIME REAMINING * ' ***************************************************************************** ' SUB DISPLAYTR (TIME.REMAINING!) STATIC CALL TIMEREMAIN (TIME.REMAINING!) CALL QTPUT (STR$(INT(TIME.REMAINING!))+" min left",1) END SUB ' $SUBTITLE: 'AMORPM - subroutine to give time of day in AM/PM format' ' $PAGE ' ' SUBROUTINE NAME -- AMORPM ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SUBROUTINE.PARAMETER = 1 GET CURRENT TIME AND DATE ' SUBROUTINE.PARAMETER = 2 CALCULATE TIME AS AM OR PM ' ' OUTPUT PARAMETERS -- CURRENT.DATE$ CURRENT DATE (MM-DD-YY) ' TIM$ CURRENT TIME (I.E. 1:13 PM) ' TIME.LOGGEND.ON$ TIME USER LOGGED ON (HH:MM:SS) ' ' SUBROUTINE PURPOSE -- TO SET THE OUTPUT PARAMETERS AS INDICATED AND ' DESCRIBE THE TIME AS "AM" OR "PM." ' SUB AMORPM STATIC ON SUBROUTINE.PARAMETER GOTO 41500,41510 ' ' ***************************************************************************** ' * CALCULATE CURRENT TIME FOR AM OR PM * ' ***************************************************************************** ' 41500 TIME.LOGGED.ON$ = TIME$ CURRENT.DATE$ = LEFT$(DATE$ ,6) + RIGHT$(DATE$ ,2) 41510 TIM$ = TIME$ IF VAL(MID$(TIM$,1,2)) = 12 THEN _ MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))),2) : _ TIM$ = LEFT$(TIM$,5) + " PM" : _ EXIT SUB IF VAL(MID$(TIM$,1,2)) > 11 THEN _ MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))-12),2) : _ TIM$ = LEFT$(TIM$,5) + " PM" : _ EXIT SUB TIM$ = LEFT$(TIM$,5) + " AM" END SUB ' $SUBTITLE: 'CARRIER - subroutine to monitor carrier on comm. port' ' $PAGE ' ' SUBROUTINE NAME -- CARRIER ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LOCAL.USER = 0 REMOTE USER ' LOCAL.USER = -1 LOCAL KEYBOARD USER ' MODEM.STATUS.REGISTER ADDRESS OF THE COMMUNI- ' CATIONS PORT'S REGISTER ' SUBROUTINE.PARAMETER = -9 DON'T WRITE TO CALLERS ' SUBROUTINE.PARAMETER = -10 SAME AS -9, BUT DON'T ' DELAY ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = 0 CARRIER STILL PRESENT ' SUBROUTINE.PARAMETER = -1 CARRIER NOT PRESENT ' ' SUBROUTINE PURPOSE -- TO TEST IF CARRIER IS PRESENT (I.E. THE USER ' STILL ON LINE). ' SUB CARRIER STATIC TOA! = FRE("A") IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB SPEEDY = 0 IF SUBROUTINE.PARAMETER <= -9 THEN _ DONT.WRITE = -9 IF SUBROUTINE.PARAMETER = -10 THEN _ SPEEDY = -1 SUBROUTINE.PARAMETER = 0 ' ' ***************************************************************************** ' * TEST FOR CARRIER PRESENT (DROP CALLER IF CARRIER NOT PRESENT) * ' ***************************************************************************** ' 42000 IF LOCAL.USER THEN _ EXIT SUB 42010 IF INP(MODEM.STATUS.REGISTER) > 127 THEN _ EXIT SUB ' ' ***************************************************************************** ' * IN CASE USER IS 2400 BAUD, PAUSE A SECOND AND CHECK AGAIN FOR CARRIER * ' * DETECT. SOME 2400 BAUD MODEMS TAKE A WHILE TO SYNCHRONIZE THE CARRIER, * ' * HENCE A THREE-SECOND PAUSE BEFORE CHECKING AGAIN. * ' ***************************************************************************** ' IF SPEEDY = -1 THEN _ GOTO 42020 CALL DELAYIT (MODEM.INIT.WAIT.TIME) SUBROUTINE.PARAMETER = 0 IF INP(MODEM.STATUS.REGISTER) > 127 THEN _ EXIT SUB 42020 SUBROUTINE.PARAMETER = -1 IF DONT.WRITE = -9 THEN _ DONT.WRITE = 0 : _ EXIT SUB IF ALREADY.WRITTEN = -9 THEN _ EXIT SUB CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$) ALREADY.WRITTEN = -9 CALL UPDTCALR ("Carrier dropped",1) SUBROUTINE.PARAMETER = -1 END SUB ' ' $SUBTITLE: 'GRAPHIC - subroutine to find graphic version of a file' ' $PAGE ' ' SUBROUTINE NAME -- GRAPHIC ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DEFAULT$ Users graphic default ' GR Whether graphics avail ' FILE.NAME$ File to check ' ' OUTPUT PARAMETERS -- FILE.NAME$ Substitutes name of graphics ' file if it exists ' ' SUBROUTINE PURPOSE -- Checks whether there is a graphics version of ' a file, based on users graphics preference. ' Sets file name to graphics file if it exists, ' otherwise leaves file name intact. Returns file ' name to use. ' SUB GRAPHIC (DEFAULT$) STATIC 43031 IF GR THEN _ CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE) : _ IF LEN(X$) < 8 THEN _ DF$ = DR$ + _ X$ + _ DEFAULT$ + _ EXTENTION$ : _ CALL FINDIT (DF$): _ IF OK THEN _ FILE.NAME$ = DF$ END SUB ' $SUBTITLE: 'SAVEPROF - subroutine to read a user profile' ' $PAGE ' ' SUBROUTINE NAME -- SAVEPROF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BPS ' EIGHT.BIT ' EXIT.TO.DOORS ' GR ' KERMIT.FUNCTION ' MESSAGE.RECORD$ ' NODE.RECORD.INDEX ' SYSOP ' UPPER.CASE ' TIME.LOGGED.ON$ ' PRIVATE.DOOR ' RELIABLE.MODE ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- SAVES A USER'S OPTIONS AND COMMUNICATIONS PARAMETERS ' IN THE NODE RECORD WHEN A USER EXITS TO A "DOOR" SO ' THAT HE IS IN THE SAME STATUS AS WHEN HE EXITED. ' SUB SAVEPROF(IPARM) STATIC ON IPARM GOTO 43070,43080 ' ' ***************************************************************************** ' * SAVE USER PROFILE WHEN EXITING * ' ***************************************************************************** ' 43070 SUBROUTINE.PARAMETER = 3 CALL FILELOCK CALL OPENMSG FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,NODE.RECORD.INDEX MID$(MESSAGE.RECORD$,40,2) = STR$(EXIT.TO.DOORS) MID$(MESSAGE.RECORD$,42,2) = STR$(EIGHT.BIT) MID$(MESSAGE.RECORD$,44,2) = STR$(BPS) MID$(MESSAGE.RECORD$,46,2) = STR$(UPPER.CASE) MID$(MESSAGE.RECORD$,48,5) = SPACE$(5) MID$(MESSAGE.RECORD$,53,2) = STR$(GR) MID$(MESSAGE.RECORD$,55,2) = STR$(SYSOP) MID$(MESSAGE.RECORD$,64,8) = TIME.LOGGED.ON$ MID$(MESSAGE.RECORD$,72,2) = STR$(PRIVATE.DOOR) MID$(MESSAGE.RECORD$,74,2) = STR$(TRANSFER.FUNCTION) MID$(MESSAGE.RECORD$,91,2) = STR$(RELIABLE.MODE) 43080 PUT 1,NODE.RECORD.INDEX SUBROUTINE.PARAMETER = 2 CALL FILELOCK CALL OPENMSG END SUB ' $SUBTITLE: 'READPROF - subroutine to restore a user profile' ' $PAGE ' ' SUBROUTINE NAME -- READPROF ' ' INPUT PARAMETERS -- PARAMETER MEANING ' NODE.RECORD.INDEX NODE RECORD TO USE ' SYSOP.PASSWORD.1$ SYSOP'S PSEUDONYM 1 ' SYSOP.PASSWORD.2$ SYSOP'S PSEUDONYM 2 ' ' OUTPUT PARAMETERS -- USER'S OPTIONS AND COMMUNICATIONS PARAMETERS ' UPON EXITING RBBS-PC TO A "DOOR" ' ' SUBROUTINE PURPOSE -- RESET A USER'S OPTIONS AND COMMUNICATIONS PARAMETERS ' THAT WERE SAVED IN THE NODE RECORD WHEN A USER EXITED ' TO A "DOOR" SO THAT HE IS IN THE SAME STATUS AS WHEN ' HE EXITED. ' SUB READPROF STATIC ' ' ***************************************************************************** ' * RESTORE USER PROFILE WHEN RETURNING FROM DOORS * ' ***************************************************************************** ' 44000 LOCATE 24,1 PRINT "NODE INDEX", NODE.RECORD.INDEX FIELD 1, 128 AS MESSAGE.RECORD$ GET 1,NODE.RECORD.INDEX EIGHT.BIT = VAL(MID$(MESSAGE.RECORD$,42,2)) RELIABLE.MODE = VAL(MID$(MESSAGE.RECORD$,91,2)) BPS = VAL(MID$(MESSAGE.RECORD$,44,2)) CALL COMMINFO BAUD.TEST = VAL(LEFT$(BAUD.PARITY$,4)) UPPER.CASE = VAL(MID$(MESSAGE.RECORD$,46,2)) GR = VAL(MID$(MESSAGE.RECORD$,53,2)) SYSOP = VAL(MID$(MESSAGE.RECORD$,55,2)) TIME.LOGGED.ON$ = MID$(MESSAGE.RECORD$,64,8) PRIVATE.DOOR = VAL(MID$(MESSAGE.RECORD$,72,2)) TRANSFER.FUNCTION = VAL(MID$(MESSAGE.RECORD$,74,2)) IF REQUIRED.RINGS > 0 AND _ INSTR(MODEM.INIT.COMMAND$,"S0=255") THEN _ COLOR 7,0,0 _ ELSE COLOR FG,BG,BORDER IF LOCAL.USER.MODE THEN _ GOTO 44003 IF BPS = -1 THEN _ BAUD.RATE.DIVISOR = &H180 + (11*(COMPUTER.TYPE = 2)) IF BPS = -2 THEN _ BAUD.RATE.DIVISOR = &H100 + (8*(COMPUTER.TYPE = 2)) IF BPS = -3 THEN _ BAUD.RATE.DIVISOR = &H60 + (3*(COMPUTER.TYPE = 2)) IF BPS = -4 THEN _ BAUD.RATE.DIVISOR = &H30 + (1*(COMPUTER.TYPE = 2)) IF BPS = -5 THEN _ BAUD.RATE.DIVISOR = &H18 IF BPS = -6 THEN _ BAUD.RATE.DIVISOR = &HC CALL SETBAUD 44003 CALL FINDTIME (USER.LOGON.TIME!) IF MINUTES.PER.SESSION! < 1 THEN _ MINUTES.PER.SESSION! = 3 IF NOT EIGHT.BIT THEN _ OUT LINE.CONTROL.REGISTER,&H1A IF SYSOP THEN _ FIRST.NAME$ = SYSOP.PASSWORD.1$ : _ LAST.NAME$ = SYSOP.PASSWORD.2$ : _ ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + _ " " + LAST.NAME$,1,31) : _ EXIT SUB FIRST.NAME.END = INSTR(MESSAGE.RECORD$," ") LAST.NAME.END = INSTR(FIRST.NAME.END + 1,MESSAGE.RECORD$," ") FIRST.NAME$ = LEFT$(MESSAGE.RECORD$,FIRST.NAME.END-1) LAST.NAME$ = MID$(MESSAGE.RECORD$,FIRST.NAME.END + 1,LAST.NAME.END-(FIRST.NAME.END + 1)) ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + " " + LAST.NAME$,1,31) Z$ = FIRST.NAME$ END SUB ' $SUBTITLE: 'COMMINFO - subroutine for variable of users baud/parity' ' $PAGE ' ' SUBROUTINE NAME -- COMMINFO ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BPS BAUD RATE INDICATOR ' EIGHT.BIT INDICATE FOR N/8/1 ' ' OUTPUT PARAMETERS -- BAUD.PARITY$ ' ' SUBROUTINE PURPOSE -- CREATE A STRING THAT SHOWS A USERS BAUD RATE AND ' PARITY. ' SUB COMMINFO STATIC ' ' ***************************************************************************** ' * DETERMINE BAUD AND PARITY * ' ***************************************************************************** ' IF RELIABLE.MODE THEN _ RELIABLE.MODE$ = "-R," _ ELSE RELIABLE.MODE$ = "," BAUD.PARITY$ = MID$(" 300 4501200240048009600",(-4*BPS),4) + _ " BAUD" + _ RELIABLE.MODE$ + _ MID$("N,8,1E,7,1",6 + 5*EIGHT.BIT,5) END SUB ' $SUBTITLE: 'DELAYIT - subroutine to wait number of seconds specified' ' $PAGE ' ' SUBROUTINE NAME -- DELAYIT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DELAY.TIME NUMBER OF SECONDS TO DELAY ' (0 TO 3,600) ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO WAIT THE NUMBER OF SECONDS INDICATED BEFORE ' RETURNING CONTROL TO THE CALLING ROUTINE. ' SUB DELAYIT (DELAY.TIME) STATIC IF DELAY.TIME < 1 THEN _ EXIT SUB CALL FINDTIME (DELAY!) DELAY! = DELAY.TIME + DELAY! IF DELAY! < 86400! THEN _ GOTO 50520 50500 CALL FINDTIME (TI!) IF TI! > DELAY.TIME THEN _ ' IF SECONDS TO DELAY IS PAST GOTO 50500 ' MIDNIGHT WAIT FOR THE CLOCK TO WRAP AROUND DELAY! = DELAY! - 86400! ' TO PAST MIDNIGHT AND ADJUST THE DELAY 50520 CALL FINDTIME (TI!) IF TI! < DELAY! THEN _ GOTO 50520 END SUB ' $SUBTITLE: 'MODEMPUT - subroutine to write modem commands to modem' ' $PAGE ' ' SUBROUTINE NAME -- MODEMPUT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ MODEM COMMAND ' COMMANDS.BETWEEN.RINGS INDICATOR TO WAIT FOR ' MODEM TO STOP RINGING ' BEFORE ISSUING COMMANDS ' DUMB.MODEM INDICATOR THAT MODEM WOULD ' NOT UNDERSTAND COMMANDS ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO ISSUE MODEM COMMANDS TO THE MODEM ' SUB MODEMPUT (STRNG$) STATIC ' ' ***************************************************************************** ' * SEND MODEM COMMAND * ' ***************************************************************************** ' 52070 IF DUMB.MODEM THEN _ EXIT SUB IF NOT COMMANDS.BETWEEN.RINGS OR _ NOT (INP(MODEM.STATUS.REGISTER) AND &H40) THEN _ GOTO 52080 CALL FINDTIME (CONNECT.DELAY!) CONNECT.DELAY! = CONNECT.DELAY! + 7 52072 IF (INP(MODEM.STATUS.REGISTER) AND &H40) > 0 THEN _ CALL FINDTIME (TI!) : _ IF TI! > CONNECT.DELAY! OR _ (ABS(CONNECT.DELAY! - TI!) > 30 AND _ (TI! + 86400 > CONNECT.DELAY!)) THEN _ GOTO 52080 GOTO 52072 52080 CALL DELAYIT (MODEM.COMMAND.DELAY.TIME) PRINT #3,STRNG$ END SUB ' $SUBTITLE: 'FINDFUNC - subroutine to find if function key was pressed' ' $PAGE ' ' SUBROUTINE NAME -- FINDFUNC ' ' INPUT PARAMETERS -- PARAMETER MEANING ' F1.KEY FUNCTION KEY ONE VALUE ' F10.KEY FUNCTION KEY TEN VALUE ' ' OUTPUT PARAMETERS -- FUNCTION.KEY (VALUE 1 TO 10 CORRESPONDING TO ' THE FUNCTION KEY THAT WAS PRESSED). ' KEY.PRESSED$ (CHARACTER STRING INPUTTED). ' ' SUBROUTINE PURPOSE -- TO DETERMINE IF A FUNCTION HAS BEEN PRESSED ON ' THE PC'S KEYBOARD THAT IS RUNNING RBBS-PC. ' SUB FINDFUNC STATIC ' ' ***************************************************************************** ' * TEST FOR FUNCTION KEY PRESSED * ' ***************************************************************************** ' 58040 KEY.PRESSED$ = INKEY$ FUNCTION.KEY = 0 IF LEN(KEY.PRESSED$) <> 2 THEN _ EXIT SUB KEY.PRESSED = ASC(RIGHT$(KEY.PRESSED$,1)) IF LOCAL.USER.MODE THEN _ KEY.PRESSED$ = "" : _ EXIT SUB IF KEY.PRESSED >= F1.KEY AND _ KEY.PRESSED <= F10.KEY THEN _ FUNCTION.KEY = KEY.PRESSED - 58:_ EXIT SUB IF KEY.PRESSED = 79 THEN _ 'End FUNCTION.KEY = 11 : _ EXIT SUB IF KEY.PRESSED = 72 THEN _ 'up arrow CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB _ ELSE ADJUSTED.SECURITY = TRUE : _ USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + 1: _ SUBROUTINE.PARAMETER = 2: _ CALL LINE25: _ CALL CALLOPT : _ EXIT SUB IF KEY.PRESSED = 73 THEN _ 'PgUp FUNCTION.KEY = 12 : _ EXIT SUB IF KEY.PRESSED = 80 THEN _ 'Down arrow CALL CARRIER : _ IF SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB_ ELSE ADJUSTED.SECURITY = TRUE:_ USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - 1: _ SUBROUTINE.PARAMETER = 2: _ CALL LINE25: _ CALL CALLOPT : _ EXIT SUB END SUB ' $SUBTITLE: 'FINDTIME - subroutine to calculate seconds since midnight' ' $PAGE ' ' SUBROUTINE NAME -- FINDTIME ' ' INPUT PARAMETERS -- PARAMETER MEANING ' SECONDS! VARIABLE TO RETURN RESULTS WITH ' ' OUTPUT PARAMETERS -- SECONDS! SECONDS SINCE MIDNIGHT ' ' SUBROUTINE PURPOSE -- TO CALCULATE THE NUMBER OF SECONDS THAT HAVE ' ELASPED SINCE MIDNIGHT ' SUB FINDTIME (SECONDS!) STATIC 58050 SECONDS! = TIMER END SUB ' $SUBTITLE: 'ALLCAPS - subroutine to convert string to upper case' ' $PAGE ' ' SUBROUTINE NAME -- ALLCAPS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' CONVERT.FIELD$ STRING TO MAKE UPPER CASE ' ' OUTPUT PARAMETERS -- CONVERT.FIELD$ CONVERTED STRINGS ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO CONVERT A STRING TO UPPER CASE ' SUB ALLCAPS (CONVERT.FIELD$) STATIC 58060 IF TURBO.RBBS THEN _ CALL RBBSULC (CONVERT.FIELD$) : _ EXIT SUB FOR Z = 1 TO LEN(CONVERT.FIELD$) IF MID$(CONVERT.FIELD$,Z,1) > "@" THEN _ MID$(CONVERT.FIELD$,Z,1) = CHR$(ASC(MID$(CONVERT.FIELD$,Z,1)) AND 223) NEXT END SUB ' $SUBTITLE: 'ALLCAPSD - subroutine to convert string to upper case' ' $PAGE ' ' SUBROUTINE NAME -- ALLCAPSD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' CONVERT.FIELD$ DIMENSIONED STRING TO MAKE ' UPPER CASE ' ' OUTPUT PARAMETERS -- CONVERT.FIELD$ CONVERTED STRINGS ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO CONVERT A STRING TO UPPER CASE ' SUB ALLCAPSD (CONVERT.FIELD$(1),CONVERT.INDEX) STATIC 58065 IF TURBO.RBBS THEN _ CALL RBBSULC (CONVERT.FIELD$(CONVERT.INDEX)) : _ EXIT SUB FOR Z = 1 TO LEN(CONVERT.FIELD$(CONVERT.INDEX)) IF MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1) > "@" THEN _ MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1) = CHR$(ASC(MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1)) AND 223) NEXT END SUB ' $SUBTITLE: 'CHECKTIM - subroutine to see if time has elasped' ' $PAGE ' ' SUBROUTINE NAME -- CHECKTIM ' ' INPUT PARAMETERS -- PARAMETER MEANING ' MAX.TIME! NUMBER OF SECONDS PAST MIDNIGHT ' NOT TO EXCEED ' ' OUTPUT PARAMETERS -- SUBROUTINE.PARAMETER = 1 CURRENT TIME IS LESS THAN ' MAX.TIME! ' SUBROUTINE.PARAMETER = 2 CURRENT TIME IS GREATER THAN ' OR EQUAL TO MAX.TIME! ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO CHECK IF THE CURRENT TIME IS GREATER ' THAN OR EQUAL TO THE TIME ALLOWED ' SUB CHECKTIM (MAX.TIME!) STATIC 58070 SUBROUTINE.PARAMETER = 1 CALL FINDTIME (TI!) IF MAX.TIME! < 86400 AND TI! < MAX.TIME! THEN _ EXIT SUB IF MAX.TIME! < 86400 AND TI! => MAX.TIME! THEN _ SUBROUTINE.PARAMETER = 2 : _ EXIT SUB TEST.TIME! = MAX.TIME! - 86400 IF TEST.TIME! - TI! <= 0 THEN _ EXIT SUB IF TI! => TEST.TIME! THEN _ SUBROUTINE.PARAMETER = 2 END SUB ' $SUBTITLE: 'HASHRBBS - subroutine to determine where to look for user' ' $PAGE ' ' SUBROUTINE NAME -- HASHRBBS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG.TO.HASH$ USER NAME TO LOCATE ' MAX.POSITION MAXIMUM # USERS ' ' OUTPUT PARAMETERS -- PRIME.HASH WHERE TO LOOK FIRST ' SECOND.HASH LOOK THIS FAR AHEAD ' ' SUBROUTINE PURPOSE -- WHERE TO LOOK FOR A USER IN USERS FILE ' LOOK FIRST AT PRIME POSITION, THEN ADD ' SECOND.HASH UNTIL FIND OR FIND UNUSED RECORD ' SUB HASHRBBS (STRNG.TO.HASH$,MAX.POSITION,PRIME.HASH,SECOND.HASH) STATIC 58080 SECOND.HASH = (ASC(MID$(STRNG.TO.HASH$,2,1))*10 + 7) MOD _ MAX.POSITION PRIME.HASH = _ ((ASC(STRNG.TO.HASH$)*100 + _ ASC(MID$(STRNG.TO.HASH$,LEN(STRNG.TO.HASH$) / 2,1)) * _ 10 + _ ASC(RIGHT$(STRNG.TO.HASH$,1))) _ MOD MAX.POSITION) + 1 END SUB ' $SUBTITLE: 'CALLOPT - subroutine to set prompts based on user security' ' $PAGE ' ' SUBROUTINE NAME -- CALLOPT ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BEG.MAIN POSITION START OF MAIN CMDS ' BEG.FILE POSITION START OF FILE CMDS ' BEG.UTIL POSITION START OF UTIL CMDS ' ' OUTPUT PARAMETERS -- PRESENT.OPTS$ DISPLAY WHAT USER CAN DO (1st) ' CALLERS.OPTS$ DISPLAY WHAT USER CAN DO (2nd) ' MAIN.OPTS$ MAIN OPTS USER CAN DO ' FILE.OPTS$ FILE OPTS USER CAN DO ' UTIL.OPTS$ UTIL OPTS USER CAN DO ' ' SUBROUTINE PURPOSE -- SETS COMMAND LINE DISPLAY OF WHAT USER CAN DO BY ' SECTION AND DISPLAY OF WHAT ALL USER CAN DO ' SUB CALLOPT STATIC 58090 FIRST = BEG.MAIN LAST = BEG.FILE - 1 CALL SETOPTS (MAIN.OPTS$,FIRST,LAST) FIRST = BEG.FILE LAST = BEG.UTIL - 1 CALL SETOPTS (FILE.OPTS$,FIRST,LAST) FIRST = BEG.UTIL LAST = BEG.UTIL + 10 CALL SETOPTS (UTIL.OPTS$,FIRST,LAST) FIRST = 40 LAST = 46 CALL SETOPTS (SYS.OPTS$,FIRST,LAST) FIRST = 36 LAST = 39 CALL SETOPTS (GLOBAL.OPTS$,FIRST,LAST) PRESENT.OPTS$ = "Your valid commands are:" IF LEN(GLOBAL.OPTS$) > 0 THEN _ PRESENT.OPTS$ = PRESENT.OPTS$ + " Globals: " + GLOBAL.OPTS$ CALLERS.OPTS$ = "Main: " + MAIN.OPTS$ + _ " File: " + FILE.OPTS$ + _ " Util: " + UTIL.OPTS$ IF LEN(SYS.OPTS$)>0 THEN _ CALLERS.OPTS$ = CALLERS.OPTS$ + " Sysop: " + SYS.OPTS$ MAIN.OPTS$ = GLOBAL.OPTS$ + MAIN.OPTS$ FILE.OPTS$ = GLOBAL.OPTS$ + FILE.OPTS$ UTIL.OPTS$ = GLOBAL.OPTS$ + UTIL.OPTS$ CALL SRTSTRNG (SYS.OPTS$) CALL SRTSTRNG (MAIN.OPTS$) MAIN.OPTS$ = MAIN.OPTS$ + SYS.OPTS$ CALL SRTSTRNG (FILE.OPTS$) CALL SRTSTRNG (UTIL.OPTS$) CALL INSCOMMA (MAIN.OPTS$) CALL INSCOMMA (FILE.OPTS$) CALL INSCOMMA (UTIL.OPTS$) DIR.PROMPT$ = "What directories (" + _ MID$("<U>pload,<A>ll,[ENTER] ", _ 9*(USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW)+10) END SUB ' $SUBTITLE: 'SETOPTS - subroutine to set prompts based on user security' ' $PAGE ' ' SUBROUTINE NAME -- SETOPTS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FIRST POSITION WHERE START LOOKING ' LAST POSITION WHERE QUIT LOOKING ' USER.SECURITY.LEVEL SECURITY OF USER ' ' OUTPUT PARAMETERS -- OPTIONS$ LIST OF COMMANDS USER CAN DO ' ' SUBROUTINE PURPOSE -- STRING TOGETHER WHAT COMMANDS USER CAN DO ' IN A SECTION ' SUB SETOPTS (OPTIONS$,FIRST,LAST) STATIC 58100 OPTIONS$ = "" FOR I = FIRST TO LAST IF USER.SECURITY.LEVEL >= OPT.SEC(I) THEN _ IF MID$(ALL.OPTS$,I,1) <> " " THEN _ OPTIONS$ = OPTIONS$ + MID$(ALL.OPTS$,I,1) NEXT CALL SRTSTRNG (OPTIONS$) END SUB ' $SUBTITLE: 'CHKNEWBUL - subroutine to check whether got new bulletins' ' $PAGE ' ' SUBROUTINE NAME -- CHKNEWBUL ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LAST.ON$ Last date of logon ' format mm/dd/yy ' ACTIVE.BULLETINS # of bulletins ' BULLETIN.PREFIX$ Filespec for bulletins ' ' OUTPUT PARAMETERS -- NUM.NEW.BULLETS Number of new bulletins ' NEW.BULLETS$ List of new bullet #'s ' Q where last bulletin stored ' in B$() ' B$() Bulletins #'s that are new ' (2,3,4,...) ' SUBROUTINE PURPOSE -- Checks how many bulletins have system date ' at or later than date caller last logged on ' SUB CHKNEWBUL (LAST.ON$,NUM.NEW.BULLETS,NEW.BULLETS$) STATIC 58110 NUM.NEW.BULLETS = 0 NEW.BULLETS$ = ": " BASE.DATE# = VAL(MID$(LAST.ON$,4,2)) + (100 * VAL(MID$(LAST.ON$,1,2))) + _ (10000# * (1900 + VAL(MID$(LAST.ON$,7,2)))) FOR I = 1 TO ACTIVE.BULLETINS Y$ = MID$(STR$(I),2) X$ = BULLETIN.PREFIX$ + Y$ + CHR$(0) CALL RBBSFIND (X$,IX,YY,MM,DD) IF IX = 0 THEN _ FDATE# = DD + (100 * MM) + (10000# * (YY+1980)) : _ IF BASE.DATE# <= FDATE# THEN _ NUM.NEW.BULLETS = NUM.NEW.BULLETS + 1 : _ B$(NUM.NEW.BULLETS+1) = Y$ : _ NEW.BULLETS$ = NEW.BULLETS$ + " " + Y$ NEXT Q = NUM.NEW.BULLETS+1 IF NUM.NEW.BULLETS < 1 THEN _ NEW.BULLETS$ = "" END SUB ' $SUBTITLE: 'SRTSTRNG - subroutine to sort characters in a string' ' $PAGE ' ' SUBROUTINE NAME -- SRTSTRNG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ String to sort ' ' OUTPUT PARAMETERS -- STRNG$ Sorted string ' ' SUBROUTINE PURPOSE -- Sorts characters in passed string. ' SUB SRTSTRNG (STRNG$) STATIC 58120 S0 = LEN(STRNG$) S1 = S0 X$ = "!" 58122 S1 = S1\2 IF S1 = 0 THEN _ EXIT SUB S2 = S0 - S1 FOR S3 = 1 TO S2 S4 = S3 58124 S5 = S4 + S1 IF MID$(STRNG$,S4,1) > MID$(STRNG$,S5,1) THEN _ LSET X$ = MID$(STRNG$,S4,1):_ MID$(STRNG$,S4,1) = MID$(STRNG$,S5,1):_ MID$(STRNG$,S5,1) = X$: _ S4 = S4 - S1:_ IF S4 > 0 THEN _ GOTO 58124 NEXT GOTO 58122 END SUB ' $SUBTITLE: 'INSCOMMA - subroutine to format commands in command prompt' ' $PAGE ' ' SUBROUTINE NAME -- INSCOMMA ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ String to replace ' ' OUTPUT PARAMETERS -- STRNG$ Replaced string ' ' SUBROUTINE PURPOSE -- Inserts commands between each letter in STRNG$ ' and encloses in pointed brackets SUB INSCOMMA (STRNG$) STATIC 58130 L = LEN(STRNG$) IF L < 1 THEN _ EXIT SUB LSET LINEMES$ = " <" + LEFT$(STRNG$,1) FOR K = 2 TO L MID$(LINEMES$,2*K,2) = "," + MID$(STRNG$,K,1) NEXT STRNG$ = LEFT$(LINEMES$,2*L+1) + ">" END SUB ' $SUBTITLE: 'LOADNEW - subroutine to get latest uploads' ' $PAGE ' ' SUBROUTINE NAME -- LOADNEW ' ' INPUT PARAMETERS -- PARAMETER MEANING ' UPLOAD.DIRECTORY$ List of files uploaded ' ' OUTPUT PARAMETERS -- A$ Latest uploads ' ' SUBROUTINE PURPOSE -- Loads table of most recent number of uploads ' by date SUB LOADNEW (ARA(2)) STATIC 58140 IF FMS.DIRECTORY$ = "" THEN _ EXIT SUB CALL OPENFMS (LAST.REC) FIELD 2, 23 AS PRE.DATE$,_ 2 AS MM$,_ 1 AS FILL1$,_ 2 AS DD$,_ 1 AS FILL2$,_ 2 AS YY$,_ (2+MAX.DESC.LEN) AS FILL3$,_ 3 AS CATEGORY$, _ 2 AS FILL4$ MAX.RECS = UBOUND(ARA,1) IF MAX.RECS < 1 THEN_ MAX.RECS = 1 _ ELSE IF MAX.RECS > 23 THEN _ MAX.RECS = 23 L = 0 K = LAST.REC WHILE K > 0 AND L < MAX.RECS GET #2,K IF (CAN.DOWNLOAD.FROM.UP OR CATEGORY$ <> DEFAULT.CATEGORY.CODE$) THEN _ L = L+1:_ ARA(L,1) = 366*(VAL(YY$)-80)+31*VAL(MM$)+VAL(DD$) IF NOT CAN.DOWNLOAD.FROM.UP THEN _ X = MIN.SEC.TO.VIEW _ ELSE IF CATEGORY$ = "***" THEN _ X = SYSOP.SECURITY.LEVEL _ ELSE IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _ X = MIN.SEC.TO.VIEW _ ELSE_ X = OPT.SEC(18) ARA(L,2) = X K = K - 1 WEND CLOSE 2 END SUB ' $SUBTITLE: 'CTNEWFILES - subroutine to count how many files new' ' $PAGE ' ' SUBROUTINE NAME -- CTNEWFILES ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LAST.ON$ Date of last logon ' UPLDS$ Latest uploads ' ' OUTPUT PARAMETERS -- NUM.NEW.FILES How many after last logon ' ' SUBROUTINE PURPOSE -- CHECKS HOW MANY FILES IN UPLDS$ WERE UPLOADED ON OR ' AFTER DATE OF LAST LOGON THAT THE USER CAN DOWNLOAD ' SUB CTNEWFILES (LAST.ON$,UPLDS(2),NUM.USER.FILES) STATIC 58150 BASE.DATE = 366*(VAL(MID$(LAST.ON$,7,2))-80) + _ 31*(VAL(MID$(LAST.ON$,1,2))) + _ VAL(MID$(LAST.ON$,4,2)) NUM.NEW.FILES = 1 NUM.USER.FILES = 0 WHILE (BASE.DATE <= UPLDS(NUM.NEW.FILES,1) AND _ UPLDS(NUM.NEW.FILES,1)>0 AND_ NUM.NEW.FILES < UBOUND(UPLDS,1)) IF USER.SECURITY.LEVEL >= UPLDS(NUM.NEW.FILES,2) THEN _ NUM.USER.FILES = NUM.USER.FILES + 1 NUM.NEW.FILES = NUM.NEW.FILES + 1 WEND END SUB ' $SUBTITLE: 'CTLINES - subroutine to determine file categories ' ' $PAGE ' ' SUBROUTINE NAME -- CTLINES ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DIR.CATEGORY.FILE$ NAME OF THE FILE THAT HAS THE ' NUMBER OF CATEGORIES IN IT. ' ' OUTPUT PARAMETERS -- MAX.ENTRIES NUMBER OF FILE CATEGORIES ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO COUNT THE NUMBER OF CATEGORIES THAT A ' FILE CAN BE CLASSIFIED INTO. ' SUB CTLINES (MAX.ENTRIES) STATIC 58160 MAX.ENTRIES = 3 CALL FINDIT (DIR.CATEGORY.FILE$) IF OK THEN _ WHILE NOT EOF(2):_ MAX.ENTRIES = MAX.ENTRIES + 1:_ LINE INPUT #2,A$:_ WEND CLOSE 2 IF MAX.ENTRIES < 10 THEN _ MAX.ENTRIES = 10 END SUB ' $SUBTITLE: 'INITFMS - subroutine to initialize file management system' ' $PAGE ' ' SUBROUTINE NAME -- INITFMS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' UPLOAD.DIRECTORY$ ' ' OUTPUT PARAMETERS -- CATEGORY.NAME$(), elements 1,2, possibly more ' CATEGORY.CODE$(), elements 1,2, possibly more ' CATEGORY.DESC$(), elements 1,2, possibly more ' CATEGORY.INDEX count of # elements in upload ' management system ' ' SUBROUTINE PURPOSE -- SUBROUTINE TO INITIALIZE THE RBBS-PC UPLOAD MANAGEMENT ' SYSTEM SUB INITFMS (CATEGORY.NAME$(1),CATEGORY.CODE$(1),_ CATEGORY.DESC$(1),CATEGORY.INDEX) STATIC BLNK$ = " " CATEGORY.INDEX = 0 IF FMS.DIRECTORY$ <> "" THEN _ CATEGORY.INDEX = CATEGORY.INDEX + 1:_ CATN$ = CATEGORY.NAME$(CATEGORY.INDEX) : _ CALL BRKFNAME (FMS.DIRECTORY$,DRVPATH$,CATN$,EXTENSION$,FALSE) : _ CATEGORY.NAME$(CATEGORY.INDEX) = CATN$ : _ CATEGORY.CODE$(CATEGORY.INDEX) = "":_ CATEGORY.DESC$(CATEGORY.INDEX) = "All uploads"_ ELSE_ LIMIT.SEARCH.TO.FMS = FALSE:_ EXIT SUB IF LIMIT.SEARCH.TO.FMS THEN _ CATEGORY.INDEX = CATEGORY.INDEX + 1 : _ CATEGORY.NAME$(CATEGORY.INDEX) = "ALL" : _ CATEGORY.CODE$(CATEGORY.INDEX) = "" : _ CATEGORY.DESC$(CATEGORY.INDEX) = "All files" CALL FINDIT (DIR.CATEGORY.FILE$) IF NOT OK THEN _ EXIT SUB WHILE NOT EOF(2) CATEGORY.INDEX = CATEGORY.INDEX + 1 INPUT #2, CATEGORY.NAME$(CATEGORY.INDEX),_ CATEGORY.CODE$(CATEGORY.INDEX),_ CATEGORY.DESC$(CATEGORY.INDEX) CATR$ = CATEGORY.CODE$(CATEGORY.INDEX) CALL REMOVE (CATR$,BLNK$) CATEGORY.CODE$(CATEGORY.INDEX) = CATR$ WEND CLOSE 2 END SUB ' $SUBTITLE: 'DISUPDIR - subroutine to display upload direcotry' ' $PAGE ' ' SUBROUTINE NAME -- DISUPDIR ' ' INPUT PARAMETERS -- PARAMETER MEANING ' PASSED.CATEGORIES$ FILE "CATEGORIES" TO BE INCLUDED IN ' THE SEARCH. ' SEARCH.STRING$ STRING TO SEARCH ON WITHIN THE ' FILE "CATEGORIES" SELECTED ' SEARCH.DATE$ DATE EQUAL TO OR GREATER THAN TO BE ' SEARCHED FOR WITH THE "CATEGORIES" ' AND THE STRING TO SEARCH. ' DOWNLOAD.FLAG SET TO RECORD # OF LINE TO BEGIN ' VIEWING - 0 IF AT END ' ' OUTPUT PARAMETERS -- DOWNLOAD.FLAG WHENEVER DOWNLOAD REQUESTED, SETS ' TO NEXT RECORD TO VIEW. OTHERWISE ' LEAVES AT ZERO ' ' SUBROUTINE PURPOSE -- DISPLAY THE FILES THAT MEET THE CRITERIA SELECTED IN ' RBBS-PC UPLOAD MANAGEMENT SYSTEM ON THE USERS SCREEN. ' SUB DISUPDIR (PASSED.CATEGORIES$,SEARCH.STRING$,SEARCH.DATE$,_ DOWNLOAD.FLAG) STATIC 58170 CALL ALLCAPS (SEARCH.STRING$) BLNK$ = " " STOP.INTERRUPTS = TRUE CATEGORIES$ = "," + PASSED.CATEGORIES$ + "," CAN.DOWNLOAD = (USER.SECURITY.LEVEL >= OPT.SEC(18)) CALL OPENFMS (UPLOAD.INDEX) UPLOAD.INDEX = UPLOAD.INDEX + 1 IF DOWNLOAD.FLAG > 0 THEN _ UPLOAD.INDEX = DOWNLOAD.FLAG : _ DOWNLOAD.FLAG = 0 FIELD 2,(33+MAX.DESC.LEN) AS PART.TO.PRINT$,_ 3 AS CATEGORY$,_ 2 AS FILLER$ MAX.PRINT = PAGE.LENGTH - 1 BELOW.MIN.SEC = (USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW) NON.STOP = (PAGE.LENGTH < 1) CHECK.POINT = 0 LINES.PRINTED = 0 58171 UPLOAD.INDEX = UPLOAD.INDEX - 1 IF UPLOAD.INDEX < 1 THEN _ GOTO 58177 GET #2,UPLOAD.INDEX 58172 CHECK.POINT = CHECK.POINT + 1 IF CATEGORY$ = "***" THEN _ IF NOT SYSOP THEN _ GOTO 58176 IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _ IF BELOW.MIN.SEC THEN _ GOTO 58176 58173 IF LEN(CATEGORIES$) > 2 THEN _ KEE$ = "," + CATEGORY$ + "," :_ CALL REMOVE (KEE$,BLNK$):_ IF INSTR(CATEGORIES$,KEE$)=0 THEN _ GOTO 58176 IF SEARCH.STRING$ <> "" THEN _ A$ = PART.TO.PRINT$ : _ CALL ALLCAPS (A$) : _ IF INSTR (A$,SEARCH.STRING$) = 0 THEN _ GOTO 58176 58174 IF SEARCH.DATE$ <> "" THEN _ KEE$ = MID$(PART.TO.PRINT$,30,2) + _ MID$(PART.TO.PRINT$,24,2) + _ MID$(PART.TO.PRINT$,27,2) : _ IF KEE$ < SEARCH.DATE$ THEN _ GOTO 58177 ' ' ***************************************************************************** ' * Allow the FMS to be both fast and interruptable if a local * ' * user or there is nothing in the input buffer by using QTPUT. * ' ***************************************************************************** ' 58175 IF LOCAL.USER THEN _ CALL QTPUT(PART.TO.PRINT$,1) _ ELSE _ IF EOF(3) THEN _ CALL QTPUT(PART.TO.PRINT$,1) : _ ELSE _ A$ = PART.TO.PRINT$ : _ SUBROUTINE.PARAMETER = 1 : _ CALL TPUT : _ IF RET THEN _ GOTO 58177 58176 IF LINES.PRINTED <= MAX.PRINT AND CHECK.POINT < 1000 THEN _ GOTO 58171 CALL CARRIER IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER=-1 THEN _ GOTO 58177 CALL TIMEREMAIN (TIME.REMAINING!) IF TIME.REMAINING! < 0.1 THEN _ SUBROUTINE.PARAMETER = -1 : _ GOTO 58177 IF NON.STOP THEN _ GOTO 58171 IF LINES.PRINTED <= MAX.PRINT THEN _ CALL QTPUT ("Files checked thru "+MID$(PART.TO.PRINT$,24,8),1) A$ = "MORE: [Y],N,NS" + _ LEFT$(", or file(s) to download",-24*CAN.DOWNLOAD) SUBROUTINE.PARAMETER = 1 NO.ADVANCE = TRUE CALL TGET IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = -1 THEN _ GOTO 58177 IF NO THEN_ CALL WIPELINE (42) : _ GOTO 58177 IF LEN(B$(1))>2 THEN _ IF NOT YES AND CAN.DOWNLOAD THEN _ CALL SKIPLINE (1) : _ DOWNLOAD.FLAG = UPLOAD.INDEX : _ EXIT SUB CALL WIPELINE (42) IF NON.STOP THEN IF UPLOAD.INDEX > 999 THEN _ IF (SEARCH.DATE$="" OR NOT EXPERT.USER) THEN_ A$ = STR$(UPLOAD.INDEX) + _ " files left to search. Really go non-stop? (Y/[N])":_ NO.ADVANCE = TRUE : _ CALL TGET :_ CALL WIPELINE (79) : _ IF NOT YES THEN _ NON.STOP = FALSE CHECK.POINT = 0 GOTO 58171 58177 CLOSE 2 NON.STOP = (PAGE.LENGTH < 1) STOP.INTERRUPTS = FALSE A$ = "" END SUB ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array' ' $PAGE ' ' SUBROUTINE NAME -- CHKNARY ' ' INPUT PARAMETERS -- PARAMETER MEANING ' ELEMENT$ THE STRING TO CHECK FOR ' ARRAY$() THE ARRAY TO BE SEARCHED ' NUM.ENTRIES.TO.SEARCH NUMBER OF ENTRIES WITHIN IN ' THE ARRAY TO BE SEARCHED ' ' OUTPUT PARAMETERS -- IS.IN.ARA 0 = STRING NOT FOUND IN THE ' ARRAY SPECIFIED ' OTHERWISE IT IS THE NUMBER OF ' ELEMENT WITHIN THE ARRAY THAT ' WAS FOUND TO MATCH ' ' SUBROUTINE PURPOSE -- SEARCH AN ARRAY FOR A SPECIFIED STRING AND, IF FOUND, ' RETURN THE NUMBER OF THE ELEMENT THAT MATCHED. ' SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC 58180 IS.IN.ARA = 1 CALL ALLCAPS(ELEMENT$) MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1 ARRAY$(MAX.TRIES) = ELEMENT$ WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$ IS.IN.ARA = IS.IN.ARA + 1 WEND IF IS.IN.ARA = MAX.TRIES THEN _ IS.IN.ARA = 0 END SUB ' $SUBTITLE: 'FMS - subroutine to search the upload management system' ' $PAGE ' ' SUBROUTINE NAME -- FMS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' DIR.TO.SEARCH$ RBBS-PC "DIR" CATEGORY TO LOOK ' FOR ' SEARCH.STRING$ STRING TO SEARCH FOR ' SEARCH.DATE$ DATE TO SEARCH FOR ' CATEGORY.NAME$() ' CATEGORY.CODE$() ' CATEGORY.DESC$() ' CAT.FOUND ' NUM.CATEGORIES ' ' OUTPUT PARAMETERS -- PROCESSED.IN.FMS ' DOWNLOAD.FLAG ' ' SUBROUTINE PURPOSE -- TO SEARCH THE UPLOAD MANAGMENT SYSTEM AND DISPLAY THE ' FILES BEING SEARCHED FOR AS WELL AS THE CATEGORY DE- ' SCRIPTIONS ' SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$,_ PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1),_ CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND) STATIC 58200 DOWNLOAD.FLAG = 0 CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND) IF CAT.FOUND > 0 THEN _ SUBROUTINE.PARAMETER = 5 : _ GOSUB 58202 : _ A$ = "Scanning directory " + DIR.TO.SEARCH$ + HDR$ + _ " - " + CATEGORY.DESC$(CAT.FOUND) : _ CALL TPUT : _ CAT$ = CATEGORY.CODE$(CAT.FOUND) : _ CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG) PROCESSED.IN.FMS = (CAT.FOUND > 0) EXIT SUB 58202 A$ = SEARCH.DATE$ IF LEN(A$) > 0 THEN _ A$ = MID$(A$,3) + LEFT$(A$,2) HDR$ = " for " + SEARCH.STRING$ + A$ IF LEN(HDR$) < 6 THEN _ HDR$ = "" RETURN END SUB ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string' ' $PAGE ' ' SUBROUTINE NAME -- REMOVE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' BADSTRING$ STRING CONTAINING CHARACTERS ' TO BE DELETED FROM "L$" ' L$ STRING TO BE ALTERED ' ' OUTPUT PARAMETERS -- L$ WITH THE CHARACTERS IN ' "BADSTRING#" DELETED FROM IT ' ' SUBROUTINE PURPOSE -- TO REMOVE ALL INSTANCES OF THE CHARACTERS IN ' "BADSTRING$" FROM "L$" ' SUB REMOVE (L$,BADSTRNG$) STATIC 58210 J = 0 FOR I=1 TO LEN(L$) IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN_ J = J+1:_ MID$(L$,J,1) = MID$(L$,I,1) NEXT I L$ = LEFT$(L$,J) END SUB ' $SUBTITLE: 'BUFSTRNG - subroutine to write a string with imbedded CR/LF' ' $PAGE ' ' SUBROUTINE NAME -- BUFSTRNG ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ STRING TO BE WRITTEN OUT ' DATA.SIZE LENGTH OF STRING - # LEFT ' CHARS TO OUTPUT ' ' OUTPUT PARAMETERS -- STRNG$ IS WRITTEN TO THE USER ' ' SUBROUTINE PURPOSE -- TO SEARCH THE STRING, STRNG$, FOR IMBEDDED CARRIAGE ' RETURNS AND LINE FEEDS AND WRITE OUT EACH LINE WITH ' THE APPROPRIATE SUBSTITUTION (CR/LF IF TO THE LOCAL ' SCREEN OR CR/NULLS/LF IF TO THE COMMUNICATIONS PORT). ' 58300 SUB BUFSTRNG (STRNG$,DATA.SIZE) STATIC FF = PAGE.LENGTH - 1 START.BYTE = 1 - (ASC(STRNG$)=10) IF LEN(STRNG$) < 1 THEN _ EXIT SUB 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$) CR.FOUND = (CRAT > 0) EOL.LEN = -2 * CR.FOUND IF CR.FOUND THEN _ EOD = CRAT _ ' @FORMAT ELSE EOD = DATA.SIZE + 1 NUM.BYTES = EOD - START.BYTE CALL QTPUT (MID$(STRNG$,START.BYTE,NUM.BYTES),-(CR.FOUND)) IF RET THEN _ GOTO 58309 IF LINES.PRINTED < FF THEN _ GOTO 58304 CALL CARRIER IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = -1 THEN _ GOTO 58309 IF NON.STOP THEN _ GOTO 58304 IF STOP.INTERRUPTS THEN _ A$ = "MORE: [Y],N,NS" _ ELSE _ A$ = "Press [ENTER] to continue" LINES.PRINTED = 0 SUBROUTINE.PARAMETER = 1 NO.ADVANCE = TRUE CALL TGET CALL WIPELINE (26) IF NO THEN _ IF STOP.INTERRUPTS THEN _ GOTO 58309 58304 START.BYTE = EOD + EOL.LEN IF START.BYTE <= DATA.SIZE THEN _ GOTO 58301 EXIT SUB 58309 'Common ABORT routine STOP.FILE = TRUE END SUB ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user' ' $PAGE ' ' SUBROUTINE NAME -- BUFFILE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILENAME$ NAME OF THE FILE TO WRITE TO ' OUT TO THE USER ' ' OUTPUT PARAMETERS -- NONE FILE IS WRITTEN TO THE USER ' ' SUBROUTINE PURPOSE -- TO DISPLAY A SEQUENTIAL FILE TO THE USER ' 58400 SUB BUFFILE (FILNAME$) STATIC CALL FINDIT (FILNAME$) IF NOT OK THEN _ EXIT SUB CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC) DATA.SIZE = BUFFER.SIZE FIELD 2, DATA.SIZE AS SEQ.REC$ NON.STOP = (PAGE.LENGTH < 1) STOP.FILE = FALSE IF STOP.INTERRUPTS THEN _ A$ = "* <Ctrl K>/<Ctrl X> aborts <Ctrl S> suspends *" : _ SUBROUTINE.PARAMETER = 2 : _ CALL TPUT TU = 0 58405 TU = TU + 1 IF TU < NUM.RECS THEN_ GET 2,TU _ ELSE IF TU = NUM.RECS THEN _ GET 2,TU : _ X = INSTR(SEQ.REC$,CHR$(26)) :_ IF X=0 OR X > LEN.LAST.REC THEN _ DATA.SIZE = LEN.LAST.REC _ ELSE DATA.SIZE = X-1 _ ELSE GOTO 58419 IF (NOT STOP.INTERRUPTS) THEN _ CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_ ELSE IF LOCAL.USER THEN _ CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_ ELSE IF EOF(3) THEN _ CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_ ELSE _ A$ = LEFT$(SEQ.REC$,DATA.SIZE) : _ SUBROUTINE.PARAMETER = 4 : _ CALL TPUT : _ IF SUBROUTINE.PARAMETER = -1 OR RET THEN _ GOTO 58419 CALL TIMEREMAIN (TIME.REMAINING!) IF TIME.REMAINING! < 0.1 THEN _ GOTO 58419 IF NOT STOP.FILE THEN _ GOTO 58405 58419 CLOSE 2 NON.STOP = (PAGE.LENGTH < 1) END SUB ' $SUBTITLE: 'FINDLAST - subroutine to find last occurence of a string' ' $PAGE ' ' SUBROUTINE NAME -- FINDLAST ' ' INPUT PARAMETERS -- PARAMETER MEANING ' LOOK.IN$ STRING TO LOOK INTO ' LOOK.FOR$ STRING TO SEARCH FOR ' ' OUTPUT PARAMETERS -- WHERE.FOUND POSITION IN LOOK.IN$ THAT ' LOOK.FOR$ FOUND ' NUM.FINDS HOW MANY OCCURENCES IN LOOK.IN$ ' ' SUBROUTINE PURPOSE -- Finds last occurence of LOOK.FOR$ in LOOK.IN$ and ' returns count of # of occurences. If none found, ' both returned parms are 0. ' SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC 58600 WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$) NUM.FINDS = -(WHERE.FOUND > 0) NEXT.FOUND = INSTR(WHERE.FOUND+1,LOOK.IN$,LOOK.FOR$) WHILE NEXT.FOUND > 0 NUM.FINDS = NUM.FINDS + 1 WHERE.FOUND = NEXT.FOUND NEXT.FOUND = INSTR(WHERE.FOUND+1,LOOK.IN$,LOOK.FOR$) WEND END SUB ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file' ' $PAGE ' ' SUBROUTINE NAME -- ROTORSDIR ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILNAME$ FILE NAME TO LOOK FOR ' SDIR.ARA ARRAY OF SUBDIRECTORIES ' MAX.SEARCH MAX # OF SUBDIRECTORIES ' ' OUTPUT PARAMETERS -- FNAME$ ADD SUBDIRECTORY TO THE ' FILE NAME IF FOUND. OTHER- ' WISE DON'T. ' OK TRUE IF FILE WAS FOUND ' ' SUBROUTINE PURPOSE -- HUNT THROUGH A LIST OF SUBDIRECTORIES TO DETERMINE ' IF A FILE IS IN ANY OF THEM. IF FILE IS FOUND, OPEN ' THE FILE AS FILE #2, ADD THE DRIVE/PATH TO THE FILE ' NAME, AND SETS OK TO TRUE. IF FILE ISN'T FOUND, SET ' FILE NAME TO THE LAST SUBDIRECTORY SEARCHED -- WHICH ' SHOULD BE THE UPLOAD SUBDIRECTORY. ' SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH) STATIC 58700 OK = FALSE NUM.SEARCH = 1 WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND_ SDIR.ARA$(NUM.SEARCH)<>"" X$ = SDIR.ARA$(NUM.SEARCH) + FILNAME$ CALL FINDIT (X$) NUM.SEARCH = NUM.SEARCH + 1 WEND FILNAME$ = X$ END SUB ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints' ' $PAGE ' ' SUBROUTINE NAME -- WIPELINE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' CARRIAGE.RETURN$ ' CHARS.TO.WIPE # OF CHARACTERS TO BLANK ' NULLS ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- WIPE AWAY A LINE AND LEAVE CURSOR AT BEGINNING OF THE ' SAME LINE SO THAT THE NEXT LINE WILL PRINT IN ITS ' PLACE ' SUB WIPELINE (CHARS.TO.WIPE) STATIC 58800 IF NULLS THEN _ CALL SKIPLINE (1) : _ EXIT SUB IF NOT LOCAL.USER THEN _ PRINT #3,CARRIAGE.RETURN$;SPACE$(CHARS.TO.WIPE);CARRIAGE.RETURN$ IF SNOOP THEN _ LOCATE ,1 : _ PRINT SPACE$(CHARS.TO.WIPE); : _ LOCATE ,1 END SUB ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search' ' $PAGE ' ' SUBROUTINE NAME -- GETDIRS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRNG$ OPTION TO ADD IN PROMPT ' TO EXPLAIN ENTER ' DIR.PROMPT$ BASE OF DIRECTORY PROMPT ' ' OUTPUT PARAMETERS -- B$ ' Q ' SUBROUTINE PURPOSE -- Prompt for directories to search ' SUB GETDIRS (STRNG$) STATIC 58900 A$ = DIR.PROMPT$ + STRNG$ + ")" SUBROUTINE.PARAMETER = 1 CALL TGET IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _ EXIT SUB IF INSTR("Hh",B$(1)) THEN _ CALL BUFFILE (DIRECTORY.PATH$+DIRECTORY.EXTENTION$+_ "."+DIRECTORY.EXTENTION$):_ GOTO 58900 END SUB ' ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory' ' $PAGE ' ' SUBROUTINE NAME -- CONVDIRS ' ' INPUT PARAMETERS -- PARAMETER MEANING ' STRT ELEMENT TO BEGIN WITH ' B$ ARRAY TO CONVERT ' Q LAST ELEMENT TO CONFERT ' ' OUTPUT PARAMETERS -- B$ CONVERTED DIRECTORY LIST ' ' SUBROUTINE PURPOSE -- LET THE USER PUT IN A SHORT STANDARD STRING FOR A ' DIRECTORY ' ' 58950 SUB CONVDIRS (STRT) STATIC FOR I=STRT TO Q CALL ALLCAPSD(B$(),I) IF B$(I)="U" THEN _ B$(I) = UPLOAD.DIR.CHECK$ IF B$(I) = "A" THEN _ B$(I) = "ALL" IF B$(I) = "ALL" THEN _ IF MASTER.DIRECTORY.NAME$ <> "" THEN _ B$(I) = MASTER.DIRECTORY.NAME$ : _ IF USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW THEN _ Q = Q + 1 : _ B$(Q) = UPLOAD.DIR.CHECK$ NEXT END SUB ' $SUBTITLE: 'MUSIC - subroutine to PLAY MUSIC' ' $PAGE ' ' SUBROUTINE NAME -- MUSIC ' ' INPUT PARAMETERS -- PARAMETER MEANING ' 1 PLAY CONSIDER YOURSELF(OPENING SCREEN) ' 2 PLAY WALK RIGHT IN(NEW USERS) ' 3 PLAY DRAGNET (SECURITY VIOLATION) ' 4 PLAY GOODBYE CHARLIE (GOODBYE) ' 5 PLAY TAPS (ACCESS DENIED) ' 6 PLAY OOM PAH PAH (DOWNLOAD) ' 7 PLAY THNKS FOR MEMORIES(UPLOAD) ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- PROVIDE SYSOP'S AND THE VISUALLY IMPARED WITH ' AUDITORY FEEDBACK ON WHAT RBBS-PC IS DOING ' SUB MUSIC (PASSED.ARG) STATIC 59100 FF = PASSED.ARG SUBROUTINE.PARAMETER = 0 IF (NOT MUSIC) OR LOCAL.USER.MODE THEN _ EXIT SUB ON FF GOTO 59102,59104,59106,59108,59110,59112,59114 EXIT SUB 59102 '---[Introduction CONSIDER YOURSELF]--- LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2" PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59104 '---[New User WALK RIGHT IN]--- LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8":LEC2$="C8C+8D8C8":LEC3$="B4G2" PLAY "O2 X"+VARPTR$(LEC1$)+"O3 X"+VARPTR$(LEC2$)+"O2 X"+VARPTR$(LEC3$) EXIT SUB 59106 '---[Security Violation DRAGNET THEME]--- LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2." PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59108 '---[Goodbye GOODBYE CHARLIE]--- LEC$ = "MBT180B-2.G2.F4D2." PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59110 '---[Access Denied TAPS]--- LEC1$ = "MBT90F8A16":LEC2$="C4.":LEC3$="A4F4C2.C8C16F2" PLAY "O2 X"+VARPTR$(LEC1$)+"O3 X"+VARPTR$(LEC2$)+"O2 X"+VARPTR$(LEC3$) EXIT SUB 59112 '---[Download OOM PAH PAH]--- LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2" PLAY "O2 X" + VARPTR$(LEC$) EXIT SUB 59114 '---[Upload THANKS FOR THE MEMORIES]--- LEC1$ = "MBT180C2." :LEC2$ = "A8G8F4D2" PLAY "O3 X" + VARPTR$(LEC1$)+ "O2 X" + VARPTR$(LEC2$) END SUB ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in two bytes' ' $PAGE ' ' SUBROUTINE NAME -- TWOBYTEDATE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' YY FOUR DIGIT YEAR (I.E. 1987) ' MM MONTH ' DD DAY ' RESULT$ LOCATION TO PLACE THE RESULT ' ' OUTPUT PARAMETERS -- RESULT$ TWO BYTE COMPRESSED DATE FOR USE IN ' A RANDOM RECORD ' ' SUBROUTINE PURPOSE -- COMPRESS AN 8-CHARACTER DATE INTO TWO CHARACTERS SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC 59200 RESULT$ = CHR$(((YY-1980)*2) OR -((MM AND 8)<>0)) + _ CHR$((MM AND NOT 8)*32+DD) END SUB ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date' ' $PAGE ' ' SUBROUTINE NAME -- GETYMD ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TWOBYTE$ PACKED TWO-BYTE DATE FIELD ' YMD 1 = YEAR ' 2 = MONTH ' 3 = DAY ' RESULT LOCATION TO PLACE THE RESULT ' ' OUTPUT PARAMETERS -- RESULT FOUR DIGIT RESULT OF UNPAKING THE DATE ' ' SUBROUTINE PURPOSE -- UNPACK A COMPRESSED TWO-BYTE DATE FIELD ' SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC ON YMD GOTO 59205,59210,59215 EXIT SUB 59205 RESULT = (ASC(TWOBYTE$)AND NOT 1)/2 + 1980 EXIT SUB 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2))/32))OR((ASC(TWOBYTE$)AND 1)*8) EXIT SUB 59215 RESULT = ASC(MID$(TWOBYTE$,2))AND NOT 224 END SUB ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days' ' $PAGE ' ' SUBROUTINE NAME -- COMPDATE ' ' INPUT PARAMETERS -- PARAMETER MEANING ' YY YEAR ' MM MONTH ' DD DAY ' RESULT! LOCATION TO PLACE THE RESULT ' ' OUTPUT PARAMETERS -- RESULT! COMPUTE COMPUTATIONAL DATE ' ' SUBROUTINE PURPOSE -- COMPUTES A COMPUTATIONAL DATE FROM YEAR, MONTH, DAY. ' RESULTS MAY BE USED TO COMPUTE THE NUMBER OF ELASPED ' DAYS BETWEEN TWO DATES. YOU MAY PASS A 2 OR 4 DIGIT ' YEAR, BUT FOR MEANINGFUL RESULTS, BE CONSISTENT ' SUB COMPDATE (YY,MM,DD,RESULT!) STATIC RESULT! = YY*365.0 + _ INT((YY-1)/4) + _ (MM-1)*28 + _ VAL(MID$("000303060811131619212426",(MM-1)*2+1,2)) - _ ((MM>2)AND((YY MOD 4)=0)) + _ DD END SUB ' $SUBTITLE: 'PROTOCOL - check for external protocols' ' $PAGE ' ' SUBROUTINE NAME -- PROTOCOL ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TRANSFER.OPTIONS$ FILE TRANSFER PROTOCOLS ' THAT ARE ALLOWED. ' ' OUTPUT PARAMETERS -- PCKERMIT.EXE.FILE$ FILE TO TRANSFER CONTROL TO ' FOR KERMIT PROTOCOL ' KERMIT.SUPPORT SWITCH INDICATING KERMIT IS ' AVAILABLE ' XFER.COM.FILE$ FILE TO TRANSFER CONTROL TO ' FOR YMODEM, IMODEM & YMODEMG ' XFER.SUPPORT SWITCH INDICATING THAT ' YMODEM, IMODEM & YMODEMG ' ARE AVAILABLE ' WXMODEM.COM.FILE$ FILE TO TRANSFER CONTROL TO ' FOR WXMODEM SUPPORT ' WXMODEM.SUPPORT SWITCH INDICATING THAT ' WXMODEM IS AVAILABLE ' ' SUBROUTINE PURPOSE -- TO DETERMINE IF EXTERNAL PROTOCOL'S ARE AVAILABLE ' SUB PROTOCOL STATIC 62600 XFER.SUPPORT = TRUE WXMODEM.SUPPORT = TRUE KERMIT.SUPPORT = TRUE WXMODEM.COM.FILE$ = PROTOCOL.PATH$ + "WXMODEM.COM" CALL FINDIT (WXMODEM.COM.FILE$) IF NOT OK THEN _ TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,71) + _ MID$(TRANSFER.OPTIONS$,82) : _ WXMODEM.SUPPORT = FALSE XFER.COM.FILE$ = PROTOCOL.PATH$ + "QMXFER.COM" CALL FINDIT (XFER.COM.FILE$) IF NOT OK THEN _ TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,42) + _ MID$(TRANSFER.OPTIONS$,72) : _ XFER.SUPPORT = FALSE KERMIT.EXE.FILE$ = PROTOCOL.PATH$ + "PCKERMIT.EXE" CALL FINDIT (KERMIT.EXE.FILE$) IF NOT OK THEN _ TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,33) + _ MID$(TRANSFER.OPTIONS$,43) : _ KERMIT.SUPPORT = FALSE CLOSE 2 IF KERMIT.SUPPORT = 0 AND _ XFER.SUPPORT = 0 AND _ WXMODEM.SUPPORT = 0 THEN _ TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,31) + _ MID$(TRANSFER.OPTIONS$,34) END SUB ' $SUBTITLE: 'TRANSFER - subroutine for KERMIT, YMODEM, IMODEM & YMODEM' ' $PAGE ' ' SUBROUTINE NAME -- TRANSFER ' ' INPUT PARAMETERS -- PARAMETER MEANING ' TRANSFER.FUNCTION = 1 DOWNLOAD FILE TO USER ' = 2 UPLOAD FILE TO RBBS-PC ' FILE.NAME$ NAME OF FILE FOR TRANSFER ' COM.PORT$ NAME OF COMMUNICATIONS PORT ' TO BE USED BY KERMIT (COM1 ' OR COM2) ' BPS = -1 FOR 300 BAUD ' = -2 FOR 450 BAUD ' = -3 FOR 1200 BAUD ' = -4 FOR 2400 BAUD ' = -5 FOR 4800 BAUD ' = -6 FOR 9600 BAUD ' PCKERMIT.EXE.FILE$ FILE TO TRANSFER CONTROL TO ' FOR KERMIT PROTOCOL ON ' PROTOCOL.PATH$. ' QMXFER.COM.FILE$ FILE TO TRANSFER CONTROL TO ' FOR YMODEM, IMODEM OR ' YMODEMG PROTOCOLS. ' WXMODEM.COM.FILE$ FILE TO TRANSFER CONTROL TO ' FOR WXMODEM PROTOCOL ON ' PROTOCOL.PATH$ ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- TO TRANSFER FILES USING KERMIT, YMODEM, IMODEM, ' YMODEMG OR WXMODEM PROTOCOL'S ' 62620 SUB TRANSFER STATIC IF PRIVATE.DOOR THEN _ GOTO 62629 IF TRANSFER.FUNCTION = 1 THEN _ TRANSFER.COMMAND$ = "-s " : _ A$ = " send of " _ ELSE IF TRANSFER.FUNCTION = 2 THEN _ TRANSFER.COMMAND$ = "-r ": _ A$ = " receive of " : _ IF FF = 4 THEN _ TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _ "-a " IF FF <> 4 THEN _ TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + "-f " TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _ FILE.NAME$ + _ " -l " + COM.PORT$ + _ " -c" + _ ' CARRIER DROP " -b " + _ ' LINE SPEED MID$(" 300 4501200240048009600",(-4*BPS),4) IF FF = 4 THEN _ TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _ " -p n" + _ ' PARITY = NONE " -m 31" _ ' PACKETS ELSE TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _ " -p " + _ MID$("AXCKYIGW",FF,1) + _ " -n " + _ NODE.ID$ ON FF GOTO 62628, _ ' 1 = ASCII FILE TRANSFER 62622, _ ' 2 = XMODEM (CHECKSUM) FILE TRANSFER 62622, _ ' 3 = XMODEM (CRC-16) FILE TRANSFER 62624, _ ' 4 = KERMIT FILE TRANSFER 62622, _ ' 5 = YMODEM FILE TRANSFER 62622, _ ' 6 = IMODEM FILE TRANSFER 62622, _ ' 7 = YMODEMG FILE TRANSFER 62626 ' 8 = WXMODEM FILE TRANSFER 62622 B$ = "QMXFER" IF FF<4 THEN _ Y$ = "XMODEM ":_ IF FF=2 THEN _ Y$ = Y$ + "(CHECKSUM)"_ ELSE_ Y$ = Y$ + "(CRC-16)"_ ELSE_ IF FF=6 THEN_ Y$ = "IMODEM"_ ELSE_ Y$ = "YMODEM":_ IF FF=7 THEN _ Y$ = Y$ + "G" GOTO 62628 62624 B$ = "PCKERMIT" Y$ = "KERMIT" GOTO 62628 62626 B$ = "WXMODEM" Y$ = "XMODEM (WINDOWED)" 62628 CLOSE 2 OPEN NODE.WORK.FILE$ FOR OUTPUT AS #2 B$ = PROTOCOL.PATH$ + B$ + " " + TRANSFER.COMMAND$ PRINT #2,B$ CLOSE 2 CALL QTPUT (Y$ + A$ + FILE.NAME.HOLD$ + " ready!",1) IF GO.TO.SHELL THEN _ GOTO 62629 A$(1) = DISK.FOR.DOS$ + "COMMAND /C " + B$ A$(2) = RBBS.BAT$ PRIVATE.DOOR = TRUE CALL RBBSEXIT (A$(),2) 62629 CLOSE 3 OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1 IF PRIVATE.DOOR THEN _ PRIVATE.DOOR = FALSE : _ GOTO 62630 CALL DELAYIT (2) SHELL NODE.WORK.FILE$ 62630 COM.PORT.INFO$ = COM.PORT$ + ":" + _ MID$(" 300 4501200240048009600",(-4*BPS),4) + "," + _ MID$("N,8,1E,7,1",6 + 5*EIGHT.BIT,5) + _ ",RS,CD,DS" IF LOCAL.USER THEN _ GOTO 62631 OPEN COM.PORT.INFO$ AS # 3 CALL SKIPLINE (1) 62631 IF TRANSFER.FUNCTION = 2 AND _ FF = 4 THEN _ CLS : _ CALL LINE25 62632 END SUB ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents' ' $PAGE ' ' SUBROUTINE NAME -- VIEWARC (Written by Jon Martin) ' ' INPUT PARAMETERS -- PARAMETER MEANING ' FILE.NAME$ NAME OF THE ARC FILE TO BE ' VIEWED. ' ' OUTPUT PARAMETERS -- NONE ' ' SUBROUTINE PURPOSE -- PROVIDES A MECHANISM TO PROVIDE USERS WITH THE ' CONTENTS OF AN ARC FILE PRIOR TO DOWNLOADING. SUB VIEWARC STATIC 64600 IF TURBO.RBBS THEN _ RETCODE% = 0 : _ CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _ CALL BUFFILE (ARC.WORK$) : _ EXIT SUB CLOSE 2 OPEN "R",2,FILE.NAME$,1 FIELD 2,1 AS CHAR$ BYTE.POINTER! = 1 ARC.END! = LOF(2) 64605 IF BYTE.POINTER! > ARC.END! THEN _ GOTO 64620 GET 2,BYTE.POINTER! IF CHAR$ <> CHR$(26) THEN _ GOTO 64620 BYTE.POINTER! = BYTE.POINTER! +1 GET 2,BYTE.POINTER! IF CHAR$ = CHR$(0) THEN _ GOTO 64620 ARCED.NAME$ = "" FOR X = 1 TO 12 GET 2,BYTE.POINTER! + X IF CHAR$ < CHR$(40) THEN _ GOTO 64610 ARCED.NAME$ = ARCED.NAME$ + CHAR$ NEXT 64610 A$ = ARCED.NAME$ BYTE.POINTER! = BYTE.POINTER! + 14 GOSUB 64630 TOTAL.BYTES# = WORK.BYTES# BYTE.POINTER! = BYTE.POINTER! + 10 GOSUB 64630 FINAL.BYTES# = WORK.BYTES# A$ = A$ + SPACE$(20-LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) _ + STR$(FINAL.BYTES#) _ + " bytes." CALL QTPUT(A$,1) BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4 GOTO 64605 64620 CLOSE 2 SUBROUTINE.PARAMETER = 0 CALL CARRIER A$ = "" EXIT SUB 64630 FACTOR# = 1# WORK.BYTES# = 0 FOR X = 0 TO 3 GET 2,BYTE.POINTER! + X WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$) FACTOR# = FACTOR# * 256# NEXT RETURN END SUB